Soru Aynı isimde olanların toplam sayısını bulma

[Gold_Savt]

B sütununda bulunan Şirketlerin,
D sütununda bulunan satış rakamlarının
E sütununa toplanması için makroya ihtiyacım var.
İlgilenen olursa memnun olurum.

 

[Ziynettin]

Sub test()
    Application.ScreenUpdating = False
    son = Range("B" & Rows.Count).End(3).Row
    a = Range("B6:D" & son).Value
    i = 2
    ReDim b(1 To UBound(a), 1 To 1)
        Do While i <= UBound(a)
            krt = a(i, 1)
            sat = i - 1
            topla = 0
            Do While a(i, 1) = krt
                say = say + 1
                topla = topla + a(i, 3)
                i = i + 1
                If i > UBound(a) Then Exit Do
            Loop
            b(sat, 1) = topla
        Loop
    [E7].Resize(say) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam", vbInformation
End Sub

 

[Gold_Savt]

Sub test()
    Application.ScreenUpdating = False
    son = Range("B" & Rows.Count).End(3).Row
    a = Range("B6:D" & son).Value
    i = 2
    ReDim b(1 To UBound(a), 1 To 1)
        Do While i <= UBound(a)
            krt = a(i, 1)
            sat = i - 1
            topla = 0
            Do While a(i, 1) = krt
                say = say + 1
                topla = topla + a(i, 3)
                i = i + 1
                If i > UBound(a) Then Exit Do
            Loop
            b(sat, 1) = topla
        Loop
    [E7].Resize(say) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam", vbInformation
End Sub

Teşekkürler hocam. Gerçekten harika bir çalışma.
Toplanan rakamları, satan şirketin ilk satırında değil de son satırında yazdırma şansımız var mıdır?

 

[Korhan Ayhan]

Alternatif;

Sub Toplam_Al()
    Application.ScreenUpdating = False
    
    Range("E7:E" & Rows.Count).ClearContents
    
    With Range("E7:E" & Cells(Rows.Count, 2).End(3).Row)
        .Formula = "=IF(ROW()=LOOKUP(2,1/(B:B=B7),ROW(B:B)),SUMIF(B:B,B7,D:D),"""")"
        .Value = .Value
    End With

    Application.ScreenUpdating = True
End Sub

 

[Gold_Savt]

Korhan Bey, Formül çok iyi çalışıyor. Teşekkür ediyorum.
Yalnız araya satır eklediğim zaman yazmış olduğunuz yordamı tekrar çalıştırmam gerekiyor.
Toplam al kısmında ".formula" değeri koyma şansımız yok mu acaba.

 

[Korhan Ayhan]

Eğer formül olarak kalmasını istiyorsanız aşağıdaki satırı silmelisiniz.

.Value = .Value

 

[Gold_Savt]

Teşekkür ederim Korhan Bey; Kendim gerisini yaparım sandım yapamadım.
Toplam satışı, yani toplam aldığımız yeri ".Merge" ile hücre birleştrirme yapabilir miyiz.
Bundan sonra bu konuyu kapatacağım

 

[Ziynettin]

Teşekkürler hocam. Gerçekten harika bir çalışma.
Toplanan rakamları, satan şirketin ilk satırında değil de son satırında yazdırma şansımız var mıdır?

Sub test_2()
    Application.ScreenUpdating = False
    son = Range("B" & Rows.Count).End(3).Row
    a = Range("B6:D" & son).Value
    i = 2
    ReDim b(1 To UBound(a), 1 To 1)
        Do While i <= UBound(a)
            krt = a(i, 1)
            topla = 0
            Do While a(i, 1) = krt
                say = say + 1
                topla = topla + a(i, 3)
                i = i + 1
                If i > UBound(a) Then Exit Do
            Loop
            b(say, 1) = topla
        Loop
    [E7].Resize(say) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam", vbInformation
End Sub

 

[Gold_Savt]

Ziynettin hocam teşekkür ederim. Sonucu birleştirilmiş hücre olarak ".Merge", .formula değerinde görmem gerekti. ".Value" değerinde olduğunda, sonrada ekleme yaptığımda yordamı tekrar çalıştırmak icap ediyor maalesef.

 

[Korhan Ayhan]

İşin içine hücre birleştirme girecekse aşağıdaki gibi kullanmanız gerekir.

Sub Toplam_Al()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Range("E7:E" & Rows.Count).ClearContents
    Range("E7:E" & Rows.Count).UnMerge
    
    With Range("E7:E" & Cells(Rows.Count, 2).End(3).Row)
        .Formula = "=SUMIF(B:B,B7,D:D)"
        .Value = .Value
    End With

    For X = 7 To Cells(Rows.Count, 2).End(3).Row
        Ilk_Satir = X
        Son_Satir = X
        
        For Y = X + 1 To 1000
            If Cells(X, 2) = Cells(Y, 2) Then
                Son_Satir = Y
            Else
                X = Y - 1
                Exit For
            End If
        Next
        Range("E" & Ilk_Satir & ":E" & Son_Satir).Merge
    Next

    Range("E7:E" & Son_Satir).VerticalAlignment = xlCenter

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[Ziynettin]

Ziynettin hocam teşekkür ederim. Sonucu birleştirilmiş hücre olarak ".Merge", .formula değerinde görmem gerekti. ".Value" değerinde olduğunda, sonrada ekleme yaptığımda yordamı tekrar çalıştırmak icap ediyor maalesef.

Sub test_merge()
    Application.ScreenUpdating = False
    son = Range("B" & Rows.Count).End(3).Row
    Range("E7:E" & Rows.Count).UnMerge
    a = Range("B6:D" & son).Value
    i = 2
    ReDim b(1 To UBound(a), 1 To 1)
        Do While i <= UBound(a)
            krt = a(i, 1)
            sat = i - 1
            topla = 0
            Do While a(i, 1) = krt
                say = say + 1
                topla = topla + a(i, 3)
                Range("E" & i + 5 & ":E" & sat + 6).Merge
                i = i + 1
                If i > UBound(a) Then Exit Do
            Loop
            b(sat, 1) = topla
        Loop
    [E7].Resize(say) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam", vbInformation
End Sub