اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by lionheart,

الردود الموصى بها

اريد كود برمجي يبحث عن الأرقام الموجودة في الصف العلوي

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

في العمود والصف يجمع لي جميع القيم المقابلة لنفس الرقم في العمود B

Snap_2023.03.05_16h43m55s_002_.png

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

رابط هذا التعليق
شارك

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

 

  • Like 3
رابط هذا التعليق
شارك

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

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

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

Snap_2023_03.06_07h16m16s_001_.png.0a608c01c985ae8095294d0ee5b7390d.png

 

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

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

جرب هذا

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

 

تم تعديل بواسطه محي الدين ابو البشر
رابط هذا التعليق
شارك

  • أفضل إجابة

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

مرفق ملف

 

Snap_2023.03.07_04h45m46s_001_.png

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

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

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information