طلب كود برمجي لجمع عدة خلايا متشابهه

[هاوي اكسل]

اريد كود برمجي يبحث عن الأرقام الموجودة في الصف العلوي نبحث عنها في العمود A اذا كانت القيم متساوية في العمود والصف يجمع لي جميع القيم المقابلة لنفس الرقم في العمود B

ورقة عمل Microsoft Excel جديد.xlsx

[lionheart]

Try

Sub Test()
    Dim data(), a(), b(), out(), dic As Object, dataCols As Object, i As Long
    data = Range("F2:S2").Value
    a = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(a, 1) To UBound(a, 1)
        If Not dic.Exists(a(i, 1)) Then dic.Add a(i, 1), a(i, 2) Else dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
    Next i
    ReDim b(1 To UBound(data, 2))
    Set dataCols = CreateObject("Scripting.Dictionary")
    For i = LBound(data, 2) To UBound(data, 2)
        If Not dataCols.Exists(data(1, i)) Then dataCols.Add data(1, i), i
        b(i) = dic(data(1, i))
    Next i
    ReDim out(1 To 1, 1 To UBound(data, 2))
    For i = LBound(data, 2) To UBound(data, 2)
        out(1, i) = b(dataCols(data(1, i)))
    Next i
    Range("F3:S3").Value = out
End Sub

 

[هاوي اكسل]

جزاك الله خير اخي الكريم

الله يعطيك العافية على ماتقدم

[هاوي اكسل]

حاولت اطبقة على ملف خارجي ما ظبط معي

معلومات الملف الخارجي موضحه في الصورة

مرفق ملف محاكي للملف الاصلي

 

ورقة عمل Microsoft Excel جديد11.xlsx

تم تعديل مارس 6, 2023 بواسطه هاوي اكسل

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

جرب هذا

Sub test()
Dim a
Dim i&
a = Cells(6, 3).Resize(Cells(Rows.Count, 3).End(xlUp).Row - 5, 10)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
If Not .exists(a(i, 1)) Then
.Add a(i, 1), a(i, 10)
Else: .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 10): End If
Next
x = Range(Range("M3"), Range("M3").End(xlToRight))
For Each k In .keys
Set r = Cells.Find(k, , , 1)
r.Offset(3) = .Item(k)
Next
End With
End Sub

 

تم تعديل مارس 6, 2023 بواسطه محي الدين ابو البشر

[هاوي اكسل]

الله يعطيك العافية

[lionheart]

You have to be specific from the beginning of the topic

Sub Test()
    Dim lr As Long
    With ActiveSheet
        lr = Cells(Rows.Count, "C").End(xlUp).Row
        SumValuesBySearchKeys .Range("C6:C" & lr), .Range("L6:L" & lr), .Range("M3:V3")
    End With
End Sub

Public Sub SumValuesBySearchKeys(ByVal searchRange As Range, ByVal sumRange As Range, ByVal searchKeysRange As Range)
    Dim data(), a(), b(), out(), dic As Object, dataCols As Object, i As Long
    data = searchKeysRange.Value
    a = searchRange.Value
    b = sumRange.Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(a, 1) To UBound(a, 1)
        If Not dic.Exists(a(i, 1)) Then dic.Add a(i, 1), b(i, 1) Else dic(a(i, 1)) = dic(a(i, 1)) + b(i, 1)
    Next i
    ReDim out(1 To 1, 1 To UBound(data, 2))
    Set dataCols = CreateObject("Scripting.Dictionary")
    For i = LBound(data, 2) To UBound(data, 2)
        If Not dataCols.Exists(data(1, i)) Then dataCols.Add data(1, i), i
        out(1, i) = dic(data(1, i))
    Next i
    searchKeysRange.Offset(1, 0).Value = out
End Sub

 

[هاوي اكسل]

الله يعطيك العافية اخي الكريم ممتاز جداً

الخطوة الثانية

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

مرفق ملف

 

ورقة عمل Microsoft Excel جديد11.xlsx

تم تعديل مارس 7, 2023 بواسطه هاوي اكسل

[lionheart]

I think you are not specific. You have to open a new topic with the new request