Aynı değerlerin birbiri ile toplanması

[nachuge]

Dostlarım selamlar kendime göre bir sıralama uygulaması yaptım dosya burda

http://s3.dosya.tc/server28/1XyBpW/Kitap1.rar.html

benim istediğim sıralama yapılıyor fakat aynı olan verilerinde kendi arasında toplanması yani

20 3
20 5

olan veriler tek kalemde
20 8

gibi nasıl yazılabilir.

Yardımcı olursanız sevinirim.

 

[Emir Hüseyin Çoban]

. . .

Ölçü şartları 3 tane mi yoksa tablo sağa doğru devam ediyor mu.

. . .

 

[nachuge]

evet şartlar bu kadar ama sadece çapta yani ilk sütundaki değerlere göre toplam vermesini istiyorum.

 

[Emir Hüseyin Çoban]

. . .

Kodları boş bir modüle yapıştırın.

Sub kod()
    Application.ScreenUpdating = False
    aa = Cells(Rows.Count, "A").Address
    For a = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
        If WorksheetFunction.CountIf(Range(aa & ":A" & a), Cells(a, "A")) = 1 Then
            Cells(a, "B") = WorksheetFunction.SumIf(Range("A:A"), Cells(a, "A"), Range("B:B"))
        Else
            Range("A" & a & ":C" & a).Delete Shift:=xlUp
        End If
    Next a
    
    dd = Cells(Rows.Count, "D").Address
    For d = Cells(Rows.Count, "D").End(3).Row To 2 Step -1
        If WorksheetFunction.CountIf(Range(dd & ":D" & d), Cells(d, "D")) = 1 Then
            Cells(d, "E") = WorksheetFunction.SumIf(Range("D:D"), Cells(d, "D"), Range("E:E"))
        Else
            Range("D" & d & ":F" & d).Delete Shift:=xlUp
        End If
    Next d
    
    gg = Cells(Rows.Count, "G").Address
    For g = Cells(Rows.Count, "G").End(3).Row To 2 Step -1
        If WorksheetFunction.CountIf(Range(gg & ":G" & g), Cells(g, "G")) = 1 Then
            Cells(g, "H") = WorksheetFunction.SumIf(Range("G:G"), Cells(g, "G"), Range("H:H"))
        Else
            Range("g" & g & ":I" & g).Delete Shift:=xlUp
        End If
    Next g
    
    Call sirala
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
End Sub

. . .

 

[nachuge]

Çok teşekkür ederim üstadım..