عدم ترحيل البيانات مرتين

[sam_farh]

السلام عليكم 

في الملف المرفق كلما تم الضغط علي ترحيل يتم ترحيل كل البيانات كل مره 

المطلوب ترحيل البيانات الجديده فقط 

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

ممكن حد يفدني اضيف ايه علي الكود

مشروع خزنه 1.xlsb

تم تعديل أكتوبر 13 بواسطه sam_farh

[محمد هشام.]

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

جرب هل هدا ما تقصده 

Option Explicit
Sub test()
    Dim LR As Long, i As Long, c As Long, R As Long
    Dim D As String, T As String, n As Long
    Dim Sh As Worksheet, WS As Worksheet
    Set Sh = Sheets("تحصيلات نقدية")

    LR = Range("b" & Rows.Count).End(xlUp).Row
    R = Sh.Range("a" & Rows.Count).End(xlUp).Row + 1
    D = "دفعه"
    T = "تصفيه"
    
    For i = 4 To LR
        
        c = Application.WorksheetFunction.CountIfs(Sh.Range("a2:a" & R - 1), Range("b" & i), _
                                                  Sh.Range("b2:b" & R - 1), Range("g" & i), _
                                                  Sh.Range("c2:c" & R - 1), Range("c" & i), _
                                                  Sh.Range("d2:d" & R - 1), Range("f" & i))
        
        If c = 0 And (Range("G" & i) = D Or Range("G" & i) = T) Then
            Sh.Range("a" & R).Value = Range("b" & i).Value
            Sh.Range("b" & R).Value = Range("g" & i).Value
            Sh.Range("c" & R).Value = Range("c" & i).Value
            Sh.Range("d" & R).Value = Range("f" & i).Value
            R = R + 1
            n = n + 1

        End If
    Next i
   If n > 0 Then
        MsgBox "تم ترحيل البيانات بنجاح"
    Else
        MsgBox "البيانات محدثة مسبقا"
    End If
End Sub

 

[sam_farh]

جزاك الله خيرا هو ده المطلوب 

[محمد هشام.]

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

Option Explicit
Sub test2()
    Dim lastrow&, a&, i&, n&, cnt&
    Dim f As Worksheet, WS As Worksheet, OnRng As Variant
    
    Set WS = Sheets("الخزينه")
    Set f = Sheets("تحصيلات نقدية")
    
    lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    a = f.Cells(f.Rows.Count, "A").End(xlUp).Row + 1
    
    OnRng = WS.Range("B4:G" & lastrow).Value
    
    For i = 1 To UBound(OnRng, 1)
        cnt = Application.WorksheetFunction.CountIfs(f.Range("A2:A" & a - 1), OnRng(i, 1), _
                                                     f.Range("B2:B" & a - 1), OnRng(i, 6), _
                                                     f.Range("C2:C" & a - 1), OnRng(i, 2), _
                                                     f.Range("D2:D" & a - 1), OnRng(i, 5))
        
        If cnt = 0 And (OnRng(i, 6) = "دفعه" Or OnRng(i, 6) = "تصفيه") Then
            f.Cells(a, 1).Resize(1, 4).Value = Array(OnRng(i, 1), OnRng(i, 6), OnRng(i, 2), OnRng(i, 5))
            a = a + 1
            n = n + 1
        End If
    Next i
    
    MsgBox IIf(n > 0, "تم ترحيل البيانات بنجاح", "البيانات محدثة مسبقا")
End Sub

 

مشروع خزنه 1.xlsb

تم تعديل أكتوبر 13 بواسطه محمد هشام.

[sam_farh]

فنان يا غالي اشكرك علي تعبك معي 

كود اكثر من رائع

تم تعديل أكتوبر 13 بواسطه sam_farh