أ / محمد صالح

فكرة رائعة

يجب أولا أن تعرض الكود الذي يقوم بعمل هذا التفقيط

ويمكن استعمال الذكاء الاصطناعي في عكسه

اختلاف الرأي لا يفسد للود قضية

وأنا شخصيا مع الجمع بين الحسنيين

استخدام الذكاء الاصطناعي والتعلم منه في حالة المبتدئين

وتطوير ما يعطيه لك في حالة المتقدمين

للعلم تطبيقات الذكاء الاصطناعي مازالت في طور التطوير والتغذية بقواعد بيانات عملاقة واستخدامها يزيد من جودة مخرجاتها فيما بعد

بالتوفيق

لا تنتظر أن يساعدك أحد من خلال الصورة بدون إرفاق ملف

لأنه إضاعة للوقت والجهد

قبل مشاهدة الفيديو والملف

جزاكم الله كل خير أخي الحبيب

الذكاء الاصطناعي هو أفضل اختراع بعد الانترنت

تحياتي وتقديري

المعادلة صحيحة مائة بالمائة

لأن شهر أغسطس 31 يوما

فلذلك لم يتم الشهر الثاني عشر حتى يكون الناتج 1 سنة 

وأي تعديل في المعادلة بإضافة يوم أو طرح يوم سيجعل ناتج المعادلة في غير هذه الحالات غير صحيح

ربما تحتاج لحساب الفرق بين تاريخين على اعتبار أن الشهر 30 يوما فقط بدون الاهتمام بعدد ايام الشهر الحالي سواء 28 أو 29 أو 31

وهذا موجود في المنتدى

يمكنك البحث عنه

وهذه أحد النتائج

بالتوفيق

التواصل مع صاحب الكود لتعديله ليتوافق مع نسخ 64 بت

او

تغيير نظام التشغيل ل 32بت

الموضوع بسيط جدا

أحدث تاريخ يمكنك استعمال دالة max للخلايا التي بها تواريخ مثلا

=max(b2,d2,f2,.......)

وهكذا آخر عمود فيه تاريخ

وبالنسبة لإجمالي القيم يمكنك استعمال دالة sum للخلايا التي بها قيم مثلا

=sum(a2,c2,e2,.......)

بالتوفيق

13 ساعات مضت, حسين النجدى said:

اسف على الاطاله تغير اسم الشيت من اسم الصفحه تحت

للأسف اسم الشيت مكتوب خطأ بالهاء وليس بالتاء المربوطة

يجب تطابق الاسم في الكود مع الاسم في الشيت

بالتوفيق

يمكنك عمل ذلك من خلال التنسيق الشرطي عن طريق معادلة

=OR(C$6="الجمعة",C$6="السبت")

وتطبق على الخلايا  C7:AH56

بالتوفيق

لم أقل في موديول جديد وإنما قلت في حدث التغيير يعني عند تغيير محتوى الخلايا في الشيت

وتمت إضافة الطريقة في المنشور الأصلي

يمكنك تجربة هذه الكود في حدث التغيير في شيت قوائم الفصول

مع تصويب اسم الشيت قاعدة البيانات

كلك يمين على اسم الشيت قوائم الفصول ثم view code ثم لصق هذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$5" Then
        Dim wsDatabase As Worksheet
        Dim wsLists As Worksheet
        Dim lastRow As Long
        Dim i As Long
        Dim maleRow As Long, femaleRow As Long
        Dim lastMaleNumber As Long
        
        Set wsDatabase = ThisWorkbook.Sheets("قاعدة البيانات")
        Set wsLists = ThisWorkbook.Sheets("قوائم الفصول")
        
        wsLists.Range("A7:C40").ClearContents
        wsLists.Range("D7:F40").ClearContents
        
        maleRow = 7
        femaleRow = 7
        
        lastRow = wsDatabase.Cells(wsDatabase.Rows.Count, "B").End(xlUp).Row
        
        For i = 2 To lastRow
            If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then
                If wsDatabase.Cells(i, "D").Value = "ذكر" Then
                    wsLists.Cells(maleRow, 1).Value = maleRow - 6
                    wsLists.Cells(maleRow, 2).Value = wsDatabase.Cells(i, "B").Value
                    wsLists.Cells(maleRow, 3).Value = wsDatabase.Cells(i, "M").Value
                    maleRow = maleRow + 1
                End If
            End If
        Next i
        
        lastMaleNumber = maleRow - 7
        femaleRow = 7
        
        For i = 2 To lastRow
            If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then
                If wsDatabase.Cells(i, "D").Value = "انثى" Then
                    wsLists.Cells(femaleRow, 4).Value = lastMaleNumber + (femaleRow - 6)
                    wsLists.Cells(femaleRow, 5).Value = wsDatabase.Cells(i, "B").Value
                    wsLists.Cells(femaleRow, 6).Value = wsDatabase.Cells(i, "M").Value
                    femaleRow = femaleRow + 1
                End If
            End If
        Next i
    End If
End Sub

بالتوفيق

الكود في الملف مكتوب لنواة ويندوز مختلفة مثلا 32بت والنسخة الحالية 64بت

وإذا كان لك صلاحية الدخول على الكود يمكنك وضع كلمة ptrsafe قبل اسم الدالة أو الإجراء مثل هذا الكود

#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

بالتوفيق

يمكنك استعمال هذه المعادلة في الخلية D6

=IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6,الاسماء!$F$6:$F$215,0)),"")

ثم سحب المعادلة للأسفل ويسارا

وإذا كنت تستعمل النسخ الحديثة للأوفيس يمكنك استعمال هذه المعادلة بدون سحب في الخلية D6 فقط'

=IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6:AD230,الاسماء!$F$6:$F$215,0)),"")

بالتوفيق

الأمر بسيط جدا

يمكنك تسجيل ما كرو ستحصل على كود العمليات التي قمت بها

بالتوفيق

هذا يعتمد على طريقة بنائك لعناصر القائمة ليست بوكس

أثناء إضافة العناصر إليها يمكنك التحكم في تنسيق القيم الموجودة في الخلايا مثلا بهذه الصورة

Dim i As Integer
For i = 1 To 10
    ListBox1.AddItem Format(Cells(i, 1).Value, "0.00")
Next i

هذا الكود يقوم بإضافة الخلايا من A1:A10 إلى القائمة وتنسيق الرقم بها إلى رقمين عشريين

بالتوفيق

لقد تم حل مثل هذه المشكلات كثيرا

يجب البحث اولا

وهذه أحد نتائج البحث

Showing results for 'القروش خليتين' in content posted in منتدى الاكسيل Excel . - أوفيسنا (officena.net)

بالتوفيق

بارك الله فيكم جميعا

ولإثراء الموضوع وترتيب الكود وتنظيمه يمكننا استعمال هذه الدالة بعد التحسين

تم جعل الأسماء المركبة بدلالة الكلمة الأولى في مصفوفة منفصلة عن الأسماء المركبة بدلالة الكلمة الثانية

يمكن احضار الاسم الأول بتمرير رقم 1 في المعامل الثاني للدالة

ويمكن احضار اسم الاب برقم 2 أو بدون المعامل الثاني

Function SplitName(Name As String, Optional part As Integer = 2) As String
    Dim K As String, S As String, N As Integer, M As Integer, FirstName As String
    Dim startsNames As Variant, endsNames As Variant, sName As Variant
    
    K = Trim(Name):    M = Len(K):    S = " "
    
    ' مصفوفة الأسماء المركبة التي تبدأ بكلمات معينة
    startsNames = Array("عبد", "أبو", "ابو", "ام", "أم", "ذو", "امرؤ", "سيف", "زين", "روح", "عين")
    
    ' مصفوفة الأسماء المركبة التي تنتهي بكلمات معينة
    endsNames = Array("الله", "الدين", "بالله", "الزهراء", "الهدى")
    
    If InStr(1, K, S, 1) = 0 Then
        SplitName = Name
        Exit Function
    End If
    
        ' التحقق من الأسماء المركبة التي تبدأ بكلمات معينة
        For Each sName In startsNames
            If Left(K, Len(sName) + 1) = sName & " " Then
                FirstName = Left(K, InStr(Len(sName) + 2, K, S, 1) - 1)
                SplitName = IIf(part = 1, FirstName, Mid(K, Len(FirstName) + 1, Len(K)))
                Exit Function
            End If
        Next
        
        ' التحقق من الأسماء المركبة التي تنتهي بكلمات معينة
        For Each sName In endsNames
            If InStr(1, K, sName, vbTextCompare) > 0 Then
                 FirstName = Left(K, InStr(1, K, sName, vbTextCompare) + Len(sName) - 1)
                 SplitName = IIf(part = 1, FirstName, Mid(K, Len(FirstName) + 1, Len(K)))
                Exit Function
            End If
        Next
        
        ' إذا لم يكن الاسم مركبًا، عرض الاسم الأول فقط
        FirstName = Left(K, InStr(1, K, S, 1) - 1)
        SplitName = IIf(part = 1, FirstName, Mid(K, Len(FirstName) + 1, Len(K)))
End Function

بالتوفيق

2 ساعات مضت, hussam031 said:

اذا حررت الخلية و وضعت المعادلة ضمن صفيف {} تعطي نفس الخطأ السابق

كيف وضعت المعادلة ضمن صفيف؟؟؟

الصواب أن تضغط كنترول وشيفت وانتر بدلا من انتر فقط في النسخ القديمة من الأوفيس. أما في الحديثة يكتفى بانتر فقط

بالتوفيق

ما شاء الله أنت وصلت لمستوى جميل

لماذا تقول أنك مبتدئ؟

أقترح عليك الاعتماد على العمود F في تحديد القائمة

يمكنك تجربة هذا التعديل

Sub WhatsApp()
Dim Contact As String
Dim Message As String
Dim Obj As New DataObject
Dim lr As Long
lr = Cells(Rows.Count, "F").End(xlUp).Row
For Each Cell In Range("F2:f" & lr)
Contact = Cell.Value
Message = Cell.Offset(0, 2).Value

Obj.SetText Message
Obj.PutInClipboard

ActiveWorkbook.FollowHyperlink "https://wa.me/" & Contact

Application.Wait(Now + TimeValue("00:00:06")).True

Call SendKeys("^v", True)

Application.Wait(Now + TimeValue("00:00:05")).True
Call SendKeys("~", True)
Application.Wait(Now + TimeValue("00:00:05")).True
Next

MsgBox "Done!"
End Sub

بالتوفيق

أخي الكريم

أولا آمين ولك مثل ما دعوت

ثانيا لا تحتاج إلى هذا الأمر

فالكود يقوم حذف المنقول من الصف الأعلى (مثلا السادس) وينقل إليه المنقولين من الصف الخامس

ولتنفيذ ذلك مع الخامس والرابع يمكنك تعديل أسماء الشيت الحالي والسابق في الكود

سيحذف المنقول من الخامس وينقل إليهم الناجح من الرابع

وهكذا مع الصف الرابع والثالث والثاني بعد تغيير اسم الشيت الحالي والسابق في الكود

بعدها يمكنك مسح محتويات الأعمدة التي ليس بها معادلة في الصف الأول فقط

بالتوفيق

عليكم السلام ورحمة الله وبركاته

يمكنك تجربة هذا الكود

Sub TransferData()
    Dim wsCurrent As Worksheet
    Dim wsPrevious As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim targetRow As Long

    ' تحديد الشيت الحالي والشيت السابق
    Set wsCurrent = ThisWorkbook.Sheets("6") ' قم بتغيير اسم الشيت حسب الحاجة
    Set wsPrevious = ThisWorkbook.Sheets("5") ' قم بتغيير اسم الشيت حسب الحاجة

    ' إيجاد آخر صف في الشيت الحالي
    lastRow = wsCurrent.Cells(wsCurrent.Rows.Count, "B").End(xlUp).Row

    ' مسح الصفوف التي تحتوي على كلمة "منقول" في العمود M
    For i = lastRow To 7 Step -1
        If wsCurrent.Cells(i, "M").Value = "منقول" Then
            wsCurrent.Rows(i).Delete
        End If
    Next i

    ' إيجاد آخر صف بعد المسح
    lastRow = wsCurrent.Cells(wsCurrent.Rows.Count, "B").End(xlUp).Row

    ' ترحيل البيانات من الشيت السابق
    targetRow = lastRow + 1
    For i = 7 To wsPrevious.Cells(wsPrevious.Rows.Count, "B").End(xlUp).Row
        If wsPrevious.Cells(i, "M").Value = "منقول" Then
            For j = 1 To 21 ' الأعمدة من A إلى U
                If j >= 6 And j <= 12 Then
                    wsCurrent.Cells(targetRow, j).Formula = wsPrevious.Cells(i, j).Formula
                Else
                    wsCurrent.Cells(targetRow, j).Value = wsPrevious.Cells(i, j).Value
                End If
            Next j
            targetRow = targetRow + 1
        End If
    Next i

    ' ترتيب البيانات حسب الاسم في العمود B
    wsCurrent.Range("A7:U" & targetRow - 1).Sort Key1:=wsCurrent.Range("B7"), Order1:=xlAscending, Header:=xlNo
End Sub

بالتوفيق

شكرا للكلام عن ملفات سابقة لي

الموضوع حاليا بالكود غير مجاني في جوجل

وأيضا استخدام الكائن IE أصبح غير متاح في vba

وربما نرجع للطريقة الطبيعية

نسخ الأسماء في ترجمة جوجل وترجمتها

ثم نسخ الترجمة إلى اكسل مرة أخرى

وربما يوجد أكواد vba ولكن غير مجانية أيضا

بالتوفيق

إذا عرضت الدالة الموجودة في vba ربما يمكن تحويلها إلى جوجل سكريبت

لأن الأمر يحتاج إلى دراية بلغة vba ولغة جافا سكريبت

ربما يرجع السبب لأن معادلة filter و  xloojup توجد في الإصدارات الحديثة فقط من أوفيس

2021 وما بعدها أو 365 مثلا

إذا كان لديك دالة معرفة في vba اسمها topten يجب تحويلها إلى جوجل سكريبت حتى تعمل في جوجل شيت