Benzer değerlerin karşılıklarını tek satırda toplama

[kanomen]

Merhaba arkadaşlar,

Bir konuda çok zaman kaybediyorum ver bunun için hangi formulü kullanabileceğimi bulamadım.

Ornek dosyasında göstermeye çalıştığım gibi.

h12:h23 aralığında bulunan 123/45 şeklindeki rakam dizilimini filtreleyip 123 ile eşleşen değerleri tek bir sırada toplamak istiyorum.

123/01 , 123/02, 123/03, .... değerlerinin karşılığının 123 genellemesi altında toplamaya çalışıyorum.

Sarı ile işaretlediğim alan yapmaya çalıştığım kısım.

Ornek dosyasını ekte sunuyorum, yardımcı olabilecek arkadaşlara şimdiden teşekkür ediyorum.

http://dosya.co/dpmj1ziemz61/Ornek.zip.html

 

[askm]

Sub askm()
Application.ScreenUpdating = False
sat = 12
For i = 12 To Range("D" & Rows.Count).End(3).Row
Cells(sat, "j") = Left(Cells(i, "H"), 3)
Say = WorksheetFunction.CountIf(Range(Cells(12, "J"), Cells(sat, "J")), Cells(sat, "J"))
If Say = 1 Then
    
    a = Cells(i, "d")
    b = Cells(i, "e")
    c = Cells(i, "f")

    For k = i + 1 To Range("D" & Rows.Count).End(3).Row
        If Left(Cells(i, "H"), 3) = Left(Cells(k, "H"), 3) Then
            a = a + Cells(k, "d")
            b = b + Cells(k, "e")
            c = c + Cells(k, "f")
        End If
    Next k
    Cells(sat, "k") = a
    Cells(sat, "l") = b
    Cells(sat, "m") = c
    sat = sat + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam... ", vbInformation, "ASKM"
End Sub

 

[Ziynettin]

Alternatif,

Sub mukerrer_topla()
a = Range("D12:H" & Range("D" & Rows.Count).End(3).Row)
Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If Not IsEmpty(a(i, 5)) Then
            krt = Split(a(i, 5), "/")(0)
            If Not d.exists(krt) Then
                d(krt) = d.Count + 1
            End If
        End If
    Next i
ReDim b(1 To d.Count + 1, 1 To 4)
say = 1
    b(say, 1) = a(1, 5)
    b(say, 2) = a(1, 1)
    b(say, 3) = a(1, 2)
    b(say, 4) = a(1, 3)
    For i = 2 To UBound(a)
        If Not IsEmpty(a(i, 5)) Then
            krt = Split(a(i, 5), "/")(0)
            say = d(krt) + 1
            b(say, 1) = krt
            b(say, 2) = b(say, 2) + a(i, 1)
            b(say, 3) = b(say, 3) + a(i, 2)
            b(say, 4) = b(say, 4) + a(i, 3)
        End If
    Next i
[J12].Resize(d.Count + 1, 4) = b
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[kanomen]

Değeri @Ziynettin ve @askm,

Yardımlarınız ve vakit ayırdığınız için çok teşekkür ederim.