احتاج كود تجميع المتكرر فى شيت اخر

[abouelhassan]

السلام عليكم اخوانى الافاضل

احتاج كود لجمع المتكرر فى شيت اخر

مثال

لدى حساب اسمه محمود1  عمود له به5 ومنه2 والرصيد3

ومحمود1 عمود له به4 ومنه1 والرصيد3

اريد جمعهم فى شيت اخر ليكون

الحساب محمود1 له9ومنه3الرصيد6

والتوضيح بالشيت بارك الله فيكم اخوانى الاساتذة

 

جمع المكرر.xlsxFetching info...

[محي الدين ابو البشر]

تفضل أخي الكريم

Sub test()
    Dim A As Variant: Dim w As Variant
    Dim i As Long: Dim ii As Long
    A = Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(A)
            If Not .exists(A(i, 1)) Then
                .Add A(i, 1), Array(A(i, 1), A(i, 2), A(i, 3), A(i, 4))
            Else
                w = .Item(A(i, 1))
                For ii = 1 To UBound(w)
                    w(ii) = w(ii) + A(i, ii + 1)
                Next
                .Item(A(i, 1)) = w
            End If
        Next
        Cells(6, 7).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0)
    End With
End Sub

 

جمع المكرر.xlsmFetching info...

[abouelhassan]

استاذى الفاضل اخى الكريم محي الدين ابو البشر

زادك الله من فضله وكرمه الكود ممتاز يعمل بكفاءة ينقصه شئ بسيط ان يتم التنفيذ فى SHEEt2

ربنا يراضيك يارب ان شاء الله

احترامى وتقديرى لشخصك الكريم اخى

[alihgrvdad123]

تفضل - نفس كود الاستاذ محي - اجراء بعض التعديل

جمع المكرر (1).xlsmFetching info...

[abouelhassan]

بارك الله فيك اخى الكريم استاذى alihgrvdad123

زادك الله من فضله وكرمه معلش اثقل عليك فى شرح للحلقة التكرارية التى ستتغير فى الكود فى حالة

تغير ترتيب الاعمدة لكى استطيع الاستفادة من الكود فى شيت1 اما شيت 2 الخلاصة كما هو  

غيرت فى الكود فى هذا الجزء ولكن فشلت اطمع فى شرح هذا الجزء بارك الله فيك اخى

كيف يتك تحديد الاعمدة

                .Add A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11)

احترامى وتقديرى وخالص دعائى

جمع المكرر (1).xlsmFetching info...

[محي الدين ابو البشر]

  اقتباس

أن يتم التنفيذ فى SHEEt2

Expand  

فقط استبدل 

 Cells(6, 7).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0)

بالسطر

 Sheets("Sheet2").Cells(1, 1).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0)

 

[abouelhassan]

استاذى الفاضل محي الدين ابو البشر

بارك الله فيك اخى الكريم

كنت احتاج شرح الجزء المسئول فى الكود عن تغير مكان الاعمدة لكى اقوم بالتعديل على المرفق بالاعلى اخى الكريم 

زادك الله من فضله وكرمه اشكرك

جمع المكرر (1).xlsmFetching info...

[محي الدين ابو البشر]

أخي العزيز

البداية تبدأ من المصفوفة A 

بدل

  A = Cells(1).CurrentRegion

يجب أن تكون

    A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11)

ومن ثم يجب استبدال كل A(i,1)     بـ A(i,4)

وبما أنك الغيت A(i,4) من المصفوفة Array(A(i, 9), A(i, 10), A(i, 11))

فيجب إضافة سطر آخر في النهاية 

Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys)

على كل مبين بالكود التالي

Sub test()
    Dim A As Variant: Dim w As Variant
    Dim i As Long: Dim ii As Long
'    A = Cells(1).CurrentRegion
    A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(A)
            If Not .exists(A(i, 4)) Then
                .Add A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11))
            Else
                w = .Item(A(i, 4))
                For ii = 0 To UBound(w)
                    w(ii) = w(ii) + A(i, ii + 9)
                Next
                .Item(A(i, 4)) = w
            End If
        Next
        '
         Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys)
        Sheets("الخلاصة").Cells(1, 2).Resize(.Count, 3) = Application.Index(.items, 0, 0)
        Sheets("الخلاصة").Select
    End With
End Sub

أرجو أن أكون قد أفدتك وجاهز لأي سؤال

جمع المكرر (1) (2).xlsmFetching info...

[abouelhassan]

بارك الله فيك استاذى محي الدين ابو البشر

زادك الله من فضله اللهم امين يارب 

وبارك لك وبك

احترامى وتقديرى اخى الكريم

[محي الدين ابو البشر]

بارك الله

وشكراً لك

[abouelhassan]

اخى فى الله استاذى محي الدين ابو البشر

• ذادك الله من فضله ورعاك اللهم امين
• اخى حاولت توظيف وتعديل الكود الرائع لتعديل الخلاصة الى
• 
• بارك الله فيك اخى الكريم وحفظك وزادك من فضله اللهم امين يارب
• تقبل شكرى واحترامى وتقديرى
•  

[محي الدين ابو البشر]

Sub test()
    Dim A As Variant: Dim w As Variant
    Dim i As Long: Dim ii As Long
    A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(A)
            If Not .exists(A(i, 6) & "#" & A(i, 4)) Then
                .Add A(i, 6) & "#" & A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11))
            Else
                w = .Item(A(i, 6) & "#" & A(i, 4))
                For ii = 0 To UBound(w)
                    w(ii) = w(ii) + A(i, ii + 9)
                Next
                .Item(A(i, 6) & "#" & A(i, 4)) = w
            End If
        Next
         Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys)
         Sheets("الخلاصة").Cells(1, 1).Resize(.Count).TextToColumns Destination:=Range("A1"), OtherChar:="#", FieldInfo:=Array(Array(2, 1))
        Sheets("الخلاصة").Cells(1, 3).Resize(.Count, 3) = Application.Index(.items, 0, 0)
        Sheets("الخلاصة").Select
    End With
End Sub

 

[abouelhassan]

اتقدم اليك بخالص العرفان والشكر استاذنا محي الدين ابو البشر

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

بشيت الخلاصة  اسف تعديل تصحيح ما بالصورة هادى1 محمد100 له150

خالص شكرى وتقديرى وعرفان بالجميل والدعاء من قلبى لك اخى

 

[محي الدين ابو البشر]

ما لم أفهمه كيف أتت الأرقام 450 100 50؟؟؟!!!!

[abouelhassan]

هذه غلطة اسف اخى 

الصح 150.   100.    50

اكثر الله خيرك اخى الكريم وجزاك الله خيرا يارب

اخى فى الله استاذى محي الدين ابو البشر

• ذادك الله من فضله ورعاك اللهم امين
• اخى حاولت توظيف وتعديل الكود الرائع لتعديل الخلاصة الى
• 
• بارك الله فيك اخى الكريم وحفظك وزادك من فضله اللهم امين يارب
• تقبل شكرى واحترامى وتقديرى
• للرفع رفع الله قدركم
•  

[محي الدين ابو البشر]

ماذا عن هذا

Sub test()
    Dim A As Variant: Dim w As Variant
    Dim i As Long: Dim ii As Long
    With Sheet1
    A = .Cells(1, 1).Resize(.Cells(Rows.Count, 4).End(xlUp).Row, 11)
    End With
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(A)
            If Not .exists(A(i, 6) & "#" & A(i, 4)) Then
                .Add A(i, 6) & "#" & A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11))
            Else
                w = .Item(A(i, 6) & "#" & A(i, 4))
                For ii = 0 To UBound(w)
                    w(ii) = w(ii) + A(i, ii + 9)
                Next
                .Item(A(i, 6) & "#" & A(i, 4)) = w
            End If
        Next
        Sheet2.Cells.ClearContents
         Sheet2.Cells(1, 1).Resize(.Count) = Application.Transpose(.keys)
         Sheet2.Cells(1, 1).Resize(.Count).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Other:=True, OtherChar:="#", FieldInfo:=Array(Array(2, 1))
       Sheet2.Cells(1, 3).Resize(.Count, 3) = Application.Index(.items, 0, 0)
        Sheet2.Select
    End With
End Sub

 

[abouelhassan]

تسلم وتعيش استاذى 

محي الدين ابو البشر

• تسلم ايدك ربنا يرضى عنك اخى الكريم
• بارك الله فيك اخى يعجز لسانى عن شكرك والله اشكرك اخى الكريم جدا 
• تقبل حبى واحترامى وتقديرى لك اخى فى الله

[محي الدين ابو البشر]

سلمك الله وبارك فيك ولك

شكراً