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

Gold_Savt

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
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.
 

Ekli dosyalar

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,105
Excel Vers. ve Dili
office2010
Kod:
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

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Ç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

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Kod:
a = s1.Range("A1:P" & son).Value
satırını aşağıdaki gibi düzenleyin
Kod:
a = s1.Range("A1").CurrentRegion.Value
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,372
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba Tekrar,
Ben de çalışma yapmıştım, paylaşayım.
Deneyiniz.
Sonucu ikinci sayfada listeler.
Kod:
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

Altın Üye
Katılım
5 Mart 2010
Mesajlar
227
Excel Vers. ve Dili
Ofis 2010 TR 32 Bit
Altın Üyelik Bitiş Tarihi
01-02-2025
Necdet Hocam, Ziynettin Hocam emeklerinize sağlık. Çok teşekkür ederim.
 
Üst