Makro İle Karmaşık Toplama

[leonadies]

Merhaba Üstadlar

A Sütunu Çeşitli Ürün Adları ve B sütunu bu adlara ait toplamları içermekte
C Sütunu Çeşitli Ürün Adları ve D sütunu bu adlara ait toplamları içermekte
E Sütunu Çeşitli Ürün Adları ve F sütunu bu adlara ait toplamları içermekte

İsteğim ise şöyle tüm Ürün adları K sutununa benzersiz olacak şekilde kopyalansın L sütunuda bu 3 Ayrı sütundaki karmaşık toplamları yanına yazsın. Yalnız veri girme işi devam edecek. Bir tuş yardımı ile iş bitince bu makroyu çalıştırabilmeliyim..

Dosyam Ekte

 

[Orion1]

Dosyanız ektedir.

Sub topla_59()
Dim sonsat As Long, i As Long, z As Object
Dim sut, j As Integer
Range("K2:L" & Rows.Count).ClearContents
sut = Array(0, 1, 3, 5)
Set z = CreateObject("scripting.dictionary")
For j = 1 To 3
    sonsat = Cells(Rows.Count, sut(j)).End(xlUp).Row
    For i = 2 To sonsat
        If Not z.exists(Cells(i, sut(j)).Value) Then
            z.Add (Cells(i, sut(j)).Value), Cells(i, sut(j) + 1).Value
        Else
            z.Item(Cells(i, sut(j)).Value) = z.Item(Cells(i, sut(j)).Value) _
                + Cells(i, sut(j) + 1).Value
        End If
    Next i
Next j
Range("K2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
MsgBox "işlem tamamdır"
End Sub

 

[leonadies]

Elinize sağlık üstadım Tam istedğim gibi Yine ilaç oldunuz derdime

 

[leonadies]

sayin orion1 çalışmamın bir yerinde 2 grup daha ilave etmek durumunda kaldım. Dolayısıyla K ve L sütunları 4 sutun daha kaydı. yeni sütunları nasıl ekleyebileceğimi ve toplama nasıl dahil edeceğİmi çözemedim makronuzdan nasıl yapabilirim?

 

[Orion1]

sayin orion1 çalışmamın bir yerinde 2 grup daha ilave etmek durumunda kaldım. Dolayısıyla K ve L sütunları 4 sutun daha kaydı. yeni sütunları nasıl ekleyebileceğimi ve toplama nasıl dahil edeceğİmi çözemedim makronuzdan nasıl yapabilirim?

Mavi satırlardeki yerlerde değişiklik yaptım.
N sütununda listeleniyor.

Sub topla_59()
Dim sonsat As Long, i As Long, z As Object
Dim sut, j As Integer
Range("N2:O" & Rows.Count).ClearContents
sut = Array(0, 1, 3, 5, 7, 9)
Set z = CreateObject("scripting.dictionary")
For j = 1 To 5
    sonsat = Cells(Rows.Count, sut(j)).End(xlUp).Row
    For i = 2 To sonsat
        If Not z.exists(Cells(i, sut(j)).Value) Then
            z.Add (Cells(i, sut(j)).Value), Cells(i, sut(j) + 1).Value
        Else
            z.Item(Cells(i, sut(j)).Value) = z.Item(Cells(i, sut(j)).Value) _
                + Cells(i, sut(j) + 1).Value
        End If
    Next i
Next j
Range("N2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
MsgBox "işlem tamamdır"
End Sub

 

[leonadies]

Teşekkür Ederim. Ellerinize sağlık

 

[Orion1]

Teşekkür Ederim. Ellerinize sağlık

Rica ederim.
İyi çalışmalar.