كود تجميع المبالغ اذا كان الرقم القومى مكرر

[abouelhassan]

السلام عليكم ورحمة الله اخوانى الافاضل

كل عام وانتم بخير

احتاج مساعدة بكود Vba  للتجميع بدون تكرار

لدينا شيتان الاول به ثلاث اعمدة الاسم والرقم القومى والمبلغ

والشيت الثانى اسمه تجميع بدون تكرار

احتاج كود للبحث فى عمود الرقم القومى اذا كان مكرر يجمع المبلغ 

بارك الله فيكم اخوانى الافاضل

كود تجميع .xlsx

[محمد حسن المحمد]

وعليكم السلام

هذا حل بالمعادلات إن كان يناسبك أخي الكريم

كود تجميع .xlsx

[abouelhassan]

خالص الشكر استاذ محمد حسن المحمد

اعزك الله 

احتاج كود لتنفيذ نظرا لكبر حجم الداتا 

بارك الله فيك واعزك اللهم امين يارب العالمين

[محمد هشام.]

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

بعد ادن الاستاد المحترم @محمد حسن المحمد 

تفضل جرب اخي 

Sub Total_amount()
Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"):  Set Dest = Sheets("التجميع بدون تكرار")
  a = WS.Range("B1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  Cpt = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  For i = 1 To UBound(a)
    temp = a(i, 1) & a(i, 2)
    If Not mondico.exists(temp) Then
       mondico.Add temp, ""
       For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k
       c(Cpt, k) = c(Cpt, k) + a(i, k)
       Cpt = Cpt + 1
    Else
       j = Application.Match(temp, mondico.keys, 0)
       col = UBound(a, 2)
       c(j, col) = c(j, col) + a(i, col)
    End If
 Dest.[B1:D1000] = Empty
  Next
 Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

 

كود تجميع .xlsb

تم تعديل يناير 15 بواسطه محمد هشام.

[abouelhassan]

تسلم ايدك اخى استاذ محمد هشام.

شكر وتقدير واحترام من اخيك