Yinelenen satırların değerlerini toplama

[simayakkurt]

Merhabalar

Elimdeki senaryo da A ve B sütunundaki değerler eşit ise C sütunundaki değerleri toplamam gerekiyor.

Örneğin
1. satırda A= 12 B= 25 C= 2
2. satırda A= 36 B= 25 C= 3
3. satırda A= 36 B= 25 C= 5
4. satırda A= 11 B= 28 C= 8
5. satırda A= 12 B= 25 C= 3
5. satırda A= 12 B= 25 C= 10


Sonuç olarak oluşacak tabloda;
1. satırda A= 12 B= 25 C= 15 (1.satır, 5. satır ve 6. satır A ve B değerleri aynı)
2. satırda A= 36 B= 25 C= 8 (2. satır ve 3. satır değerleri aynı )
4. satırda A= 11 B= 28 C= 8 (4. satır değeri)


bu şekilde olmalı.
Bunu formül ile ya da makro ile nasıl yapacağımı anlatan biri olursa minnettar olurum.

Şimdiden teşekkürler

 

[Orion1]

Dosyanız aşağıdaki linktedir.

DOSYAYI İNDİR

Option Base 1
Sub benzertopla59()
Dim sh As Worksheet, sonsat As Long, liste(), myarr()
Dim z As Object, n As Long, i As Long, deg As String
Set sh = Sheets("Sayfa1")
sh.Range("E:G").ClearContents
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set z = CreateObject("Scripting.dictionary")
liste = sh.Range("A1:C" & sonsat).Value
ReDim myarr(1 To 3, 1 To UBound(liste))
For i = 1 To UBound(liste)
    deg = liste(i, 1) & "|" & liste(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add (deg), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 3)
Next i
Set z = Nothing
Erase liste
ReDim Preserve myarr(1 To 3, 1 To n)
sh.Range("E1").Resize(n, 3) = Application.Transpose(myarr)
MsgBox "İşlem sonuçlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[MuratBektas41]

Dosyanız aşağıdaki linktedir.

DOSYAYI İNDİR

Option Base 1
Sub benzertopla59()
Dim sh As Worksheet, sonsat As Long, liste(), myarr()
Dim z As Object, n As Long, i As Long, deg As String
Set sh = Sheets("Sayfa1")
sh.Range("E:G").ClearContents
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set z = CreateObject("Scripting.dictionary")
liste = sh.Range("A1:C" & sonsat).Value
ReDim myarr(1 To 3, 1 To UBound(liste))
For i = 1 To UBound(liste)
    deg = liste(i, 1) & "|" & liste(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add (deg), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 3)
Next i
Set z = Nothing
Erase liste
ReDim Preserve myarr(1 To 3, 1 To n)
sh.Range("E1").Resize(n, 3) = Application.Transpose(myarr)
MsgBox "İşlem sonuçlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

Hocam eline sağlık çok işime yaradı.

 

[ramul77]

Orion1 çok teşekkürler. Harika olmuş.

 

[Seli]

Hocam benim de benzer bir problemim var. A sütununda text olarak değerler var eğer aynı ise değerler B sütunundaki value olan değerlerini toplamasını istiyorum. Nasıl yapabilirim, yardımcı olur musunuz.. Şimdiden teşekkürler..

 

[Korhan Ayhan]

Pivot Table ile çok hızlı bir şekilde istediğiniz tabloyu yapabilirsiniz.