sam_farh قام بنشر أكتوبر 13 مشاركة قام بنشر أكتوبر 13 (معدل) السلام عليكم في الملف المرفق كلما تم الضغط علي ترحيل يتم ترحيل كل البيانات كل مره المطلوب ترحيل البيانات الجديده فقط بمعني انا بدخل بيانات كل يوم ومحتاج اللي يترحل البيانات الجديده فقط يعني عدم التكرار ممكن حد يفدني اضيف ايه علي الكود مشروع خزنه 1.xlsb تم تعديل أكتوبر 13 بواسطه sam_farh رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر أكتوبر 13 أفضل إجابة مشاركة قام بنشر أكتوبر 13 وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده 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 2 رابط هذا التعليق شارك More sharing options...
sam_farh قام بنشر أكتوبر 13 الكاتب مشاركة قام بنشر أكتوبر 13 جزاك الله خيرا هو ده المطلوب 1 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أكتوبر 13 مشاركة قام بنشر أكتوبر 13 (معدل) العفو أخي يسعدنا أننا إستطعنا مساعدتك إليك طريقة أسرع ومختصرة 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 بواسطه محمد هشام. 3 رابط هذا التعليق شارك More sharing options...
sam_farh قام بنشر أكتوبر 13 الكاتب مشاركة قام بنشر أكتوبر 13 (معدل) فنان يا غالي اشكرك علي تعبك معي كود اكثر من رائع تم تعديل أكتوبر 13 بواسطه sam_farh رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان