İki değer aynı ise diğer değerleri toplama

[Gold_Savt]

Aynı Excel dosyasına birden fazla kişinin giriş yaptığı bir durumumuz var.
Benim verileri toplayıp sadeleştirmem gerekiyor.
Firma ve ürün bilgisi aynı ise diğer bilgilerin toplanmasını sağlamam lazım. Sayfamda mükerrer bilgi olmaması lazım.
Yardımlarınızı bekliyorum.

 

[Ziynettin]

Option Explicit
Private Sub CommandButton1_Click()
Dim s1 As Worksheet, a(), b(), dc As Object
Dim i As Long, son As Long, j As Byte, krt As String, say As Long
Set s1 = Sheets("Sayfa1")
son = s1.Range("A" & Rows.Count).End(xlUp).Row
If son < 2 Then Exit Sub
Set dc = CreateObject("scripting.dictionary")
a = s1.Range("A1:P" & son).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 2 To UBound(a)
        krt = a(i, 1) & "#" & a(i, 2)
        If Not dc.exists(krt) Then
            dc(krt) = dc.Count + 1
            say = dc.Count
        Else
            say = dc(krt)
        End If
        For j = 1 To 2
           b(say, j) = a(i, j)
        Next j
        For j = 3 To UBound(a, 2)
            b(say, j) = b(say, j) + a(i, j)
        Next j
    Next i
    Application.ScreenUpdating = 0
        s1.Range("A2:P" & son).ClearContents
        s1.Range("A2:P" & son).ClearFormats
        s1.[C2].Resize(dc.Count, UBound(a, 2) - 2).NumberFormat = "#,##0.00"
        s1.[A2].Resize(dc.Count, UBound(a, 2)) = b
        s1.[A2].Resize(dc.Count, UBound(a, 2)).Borders.Color = rgbSilver
        Dim rg As Range
        Set rg = s1.[A2].Resize(dc.Count, UBound(a, 2))
        rg.Sort s1.[A2], 1, , s1.[B2], 1
    Application.ScreenUpdating = 1
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[Gold_Savt]

Çok Teşekkür ederim Ziynettin Hocam. Sütun olarak "A1: P" olarak sınırlandırmamam gerekiyor. Birinci satırdaki son dolu hücre miktarınca işlem yapılabilir mi?

 

[Necdet]

Merhaba,

a = s1.Range("A1:P" & son).Value

satırını aşağıdaki gibi düzenleyin

a = s1.Range("A1").CurrentRegion.Value

 

[Necdet]

Merhaba Tekrar,
Ben de çalışma yapmıştım, paylaşayım.
Deneyiniz.
Sonucu ikinci sayfada listeler.

Sub CokSutunluToplamAl()

    Dim ar As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim str As String
    
    n = 1
    ar = Sayfa1.Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(ar, 1)
            str = ar(i, 1) & ar(i, 2)
            If Not .Exists(str) Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    ar(n, j) = ar(i, j)
                Next
                .Item(str) = n
            Else
                For j = 3 To UBound(ar, 2)
                    ar(.Item(str), j) = ar(.Item(str), j) + ar(i, j)
                Next
            End If
        Next
    End With
    
    Sayfa2.Range("A1").CurrentRegion.ClearContents
    Sayfa2.Range("A1").Resize(n, UBound(ar, 2)).Value = ar
    Sayfa2.Cells.EntireColumn.AutoFit

End Sub

 

[Gold_Savt]

Necdet Hocam, Ziynettin Hocam emeklerinize sağlık. Çok teşekkür ederim.