ترحيل اخر تحديث للتاريخ من صفحة الى الجدول الرئيسي

[Moh2024]

السلام عليكم

ممكن تعديل الكود بحيث يقوم بترحيل الخلايا اخر تحديث فقط وعدم تغيير قيم الخلاي الاخرى الصفراء الا عند التحديث.. وجزاكم الله خيرا

نموذج.xlsm

[محمد هشام.]

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

جرب هدا 

Sub UpdateDates()

    ' تعريف المتغيرات
    Dim WS As Worksheet, f As Worksheet
    Dim a As Variant, b As Variant
    Dim lr As Long, Irow As Long
    Dim i As Long, j As Long
    
    Set WS = ThisWorkbook.Sheets("CALL")
    Set f = ThisWorkbook.Sheets("DATA")
      
      
   '*** (lr)  Sheets("CALL")<<====("a")  تحديد آخر صف غير فارغ في العمود
    lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
  '*** (Irow)  Sheets("DATA")<<====("B")  تحديد آخر صف غير فارغ في العمود
    Irow = f.Cells(f.Rows.Count, "B").End(xlUp).Row
    
                '***تخزين البيانات في المتغيرات***
                
        '(A2)البيانات من النطاق Sheets("DATA")<<==== (a)تُخزن في المتغير
         a = WS.Range("A2:E" & lr).Value

        '(A2)البيانات من النطاق Sheets("CALL")<<==== (b)تُخزن في المتغير
          b = f.Range("A2:E" & Irow).Value
     
                  '******التكرار عبر الصفوف******
 '    يتم استخدام حلقتين تكراريتين For لتصفح البيانات في كل من المصفوفتين a و b

                  
   'b  Sheets("DATA")<<===='الأولى تكرر عبر الصفوف في البيانات المخزنة
    For i = 1 To UBound(b, 1)
    
    'a  Sheets("CALL")<<===='الثانية تكرر عبر الصفوف في البيانات المخزنة
    For j = 1 To UBound(a, 1)
    
    
                     '*****التحقق من المطابقة ****

'داخل الحلقة الثانية يتم التحقق من شرطين
'1======= Sheets("CALL")====>> (b) إذا كانت القيمة في العمود الثاني من
     ' Sheets("DATA")====>> (a) تساوي القيمة في العمود الأول من
            
            
 '2======= Sheets("DATA")====>> (a) وإذا كانت القيمة في العمود الثالث من
     ' Sheets("CALL")====>> (b) تساوي القيمة في العمود الثاني من
           
            If b(i, 2) = a(j, 1) And b(i, 3) = a(j, 2) Then
 'Sheets("DATA") إذا تحقق الشرطان، يتم تحديث الخلية في العمود الخامس من
 'Sheets("CALL") بالقيمة المقابلة في العمود الثالث من
                f.Cells(i + 1, 5).Value = a(j, 3)
                
           '(Exit For)الخروج من الحلقة
'يتم استخدامه للخروج من الحلقة الداخلية عند العثور
'على تطابق مما يوفر الوقت ويجعل الكود أكثر كفاءة

            Exit For
            End If
        Next j
    Next i
End Sub

 

 

نموذج V1.xlsm

تم تعديل أغسطس 25 بواسطه محمد هشام.

[Moh2024]

كل الشكر للاخ محمد هشام .. بارك الله فيك .. اذا ممكن شرح للكود للفائدة والتعلم .. جزاكم الله خيرا

[محمد هشام.]

العفو أخي @Moh2024 يسعدنا أننا إستطعنا مساعدتك 

تمت إظافة شرح الكود في المشاركة السابقة 

بالتوفيق.

[أ / محمد صالح]

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

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

Sub REs_Data()
lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Sheets("CAll").Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lr
myval = Evaluate("=IFERROR(INDEX(CAll!$C$2:$C$" & lr2 & ",MATCH(B" & r & ",CAll!$A$2:$A$" & lr2 & ",0)),"""")")
Range("E" & r).value = IIf(myval = "", Range("E" & r).value, myval)
Next r
MsgBox "Done by mr-mas.com", , "M.A.S"
End Sub

بالتوفيق

[محمد هشام.]

بطريقة أخرى 

Sub Advanced_REs_Data()
    Dim lr As Long, lr2 As Long, r As Long
    Dim f As Worksheet, WS As Worksheet
    Set f = Sheets("Data"): Set WS = Sheets("CAll")
    lr = f.Cells(Rows.Count, 2).End(xlUp).Row  
    lr2 = WS.Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To lr
        f.Range("E" & r).Value = IIf(IsError(Application.Match(f.Cells(r, 2).Value, _
            WS.Range("A2:A" & lr2), 0)), f.Range("E" & r).Value, _
            Application.Index(WS.Range("C2:C" & lr2), _
            Application.Match(f.Cells(r, 2).Value, WS.Range("A2:A" & lr2), 0)))
    Next r
        MsgBox "Process Completed", vbInformation, "Done"
End Sub

 

تم تعديل أغسطس 26 بواسطه محمد هشام.