كود جمع بيانات جدولين في ورقتين عمل

[عبدالفتاح محمد]

السلام عليكم 

لدي بيانات في ورقتين عمل اود جمع  البيانات سواء مكررة اوغير مكررة واظهار اجماليات المكرر مرة واحدة  لمزيد من التفاصيل مرفق الملف والشرح 

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

 

حساب اجماليات السلع.xls

[Ali Mohamed Ali]

وعليكم السلام-تفضل لك ما طلبت

 

حساب اجماليات السلع.xls

[سليم حاصبيا]

هذا الكود يفي بالغرض ان شاء الله

(تم تغيير اسماء الصفحات لنسخ الكود بشكل جيد وعدم الوقوع في مشاكل اللغة حيث تظهر حروف غير معروفة عند البعض)

Option Explicit

 Sub AnyThing()
        Dim lastrow_1 As Long, counter As Long
        Dim lastrow_2 As Long, key As Variant
        Dim sh1 As Worksheet, sh2 As Worksheet
        Dim rng1, rng2 As Range, p As Variant
        Dim dict As Object
    Set sh1 = Sheets("SH1")
    Set sh2 = Sheets("SH2")
    sh2.Range("I3").Resize(1000, 3).ClearContents
    
    lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row
    lastrow_2 = sh1.Cells(sh2.Rows.Count, "B").End(3).Row
    Set rng1 = sh1.Range("A3:D" & lastrow_1)
    Set rng2 = sh2.Range("A3:D" & lastrow_2)
    Set dict = CreateObject("Scripting.Dictionary")

    For Each p In rng1.Columns(2).Cells
        If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then
            dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2)
        Else
            dict(p.Value & "," & p.Offset(, 1)) = _
            dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2)
        End If
    Next p
   '===============================
       For Each p In rng2.Columns(2).Cells
        If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then
            dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2)
        Else
            dict(p.Value & "," & p.Offset(, 1)) = _
            dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2)
        End If
    Next p
           
    '==============================
   
   counter = 2
    With sh2
        For Each key In dict.Keys
             counter = counter + 1
            .Cells(counter, "I").Resize(1, 2) = Split(key, ",")
            .Cells(counter, "K") = dict(key)

        Next key
        
    End With
dict.RemoveAll: Set dict = Nothing
Set sh1 = Nothing: Set sh2 = Nothing
Set rng1 = Nothing: Set rng2 = Nothing
End Sub

 

الملف المرفق

 

 

 

Total.xlsm

[عبدالفتاح محمد]

شكر اخي سليم على هذا الكود والمجهود الذي قمت به 

[سليم حاصبيا]

اذا كان هذا المطلوب اضغط  افضل اجابة لاغلاق الموضوع

[عبدالفتاح محمد]

عدرا اخي سليم  يا ريت تدلني  من وين اجد خيار الضغط افضل اجابة 

[سليم حاصبيا]

هنا

 

[سليم حاصبيا]

انت وضعت علامة صح على مشاركتك الخاصة (اي ان اجابتك هي الافضل  دون مواخذة)

يجب وضع العلامة في المشاركة التي ارسلتها لك (حيث الكود)

[عبدالفتاح محمد]

لقد وضعتها مباشرة  في ردي بعد كودك كما طلبت مني وظهرت العلامة خضراء خرجت من موضوعي ودخلت من جديد  وجدت العلامة خضراء هل هناك مشكلة 

[سليم حاصبيا]

الان, عبدالفتاح محمد said:

لقد وضعتها مباشرة  في ردي بعد كودك كما طلبت مني وظهرت العلامة خضراء خرجت من موضوعي ودخلت من جديد  وجدت العلامة خضراء هل هناك مشكلة 

لا ليس هناك مشكلة

اعادة الضغط على العلامة الخضراء لازالتها و من ثم وضعها في المكان المناسب