Mükerrer değerleri düzenleme hk.

[OoParadiSeoO]

Arkadaşlar merhaba,

B sütununda rakamsal değerler C sütununda ise mükerrer kayıtlar mevcut.

C sütunundaki mükerrer kayıtları teke düşürüp B sütunundaki rakamsal değerini teke düşürdüğü satıra ilave etmesi gerekiyor.

Örnek;

B6=10 C6=ADANA
B7=15 C6=BURSA
B8=2 C8=ADANA

Sonuç;

B6=12 C6=ADANA
B7=15 C6=BURSA

Yardımcı olabilirmisiniz?

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False
    
    son = Cells(Rows.Count, "C").End(3).Row
    ReDim dizi(1 To 2, 1 To 1)
    
    For i = 6 To son
        If WorksheetFunction.CountIf(Range("C6:C" & i), Cells(i, "C")) = 1 Then
            s = s + 1
            ReDim Preserve dizi(1 To 2, 1 To s)
            dizi(1, s) = WorksheetFunction.SumIf(Range("C6:C" & son), Cells(i, "C"), Range("B6:B" & son))
            dizi(2, s) = Cells(i, "C").Value
        End If
    Next i
    
    Range("B6:C" & son).ClearContents
    Range("B6").Resize(s, 2).Value = Application.Transpose(dizi)

Application.ScreenUpdating = True
MsgBox "B i t t i"
End Sub

. . .

 

[OoParadiSeoO]

Hüseyin Bey teşekkürler.. Örnekte B6 C6 şeklinde belirtmiştim. Bunu A6 B6 olacak şekilde değiştrmeye çalıştım ama beceremedim. Yardımcı olabilirmisiniz..

A6=10 B6=ADANA
A7=15 B7=BURSA
A8=2 B8=ADANA

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False
    
    son = Cells(Rows.Count, "A").End(3).Row
    ReDim dizi(1 To 2, 1 To 1)
    
    For i = 6 To son
        If WorksheetFunction.CountIf(Range("A6:A" & i), Cells(i, "A")) = 1 Then
            s = s + 1
            ReDim Preserve dizi(1 To 2, 1 To s)
            dizi(1, s) = Cells(i, "A").Value
            dizi(2, s) = WorksheetFunction.SumIf(Range("A6:A" & son), Cells(i, "A"), Range("B6:B" & son))
        End If
    Next i
    
    Range("A6:B" & son).ClearContents
    Range("A6").Resize(s, 2).Value = Application.Transpose(dizi)

Application.ScreenUpdating = True
MsgBox "B i t t i"
End Sub

. . .

 

[OoParadiSeoO]

Hüseyin Bey kusura bakmayın yanlış yazmışım..

A6=ADANA B6=10
A7=BURSA B7=15
A8=ADANA B8=2

şekline uyarlamaya çalışıyorum..

 

[Emir Hüseyin Çoban]

. . .

4 nolu mesajımdaki kodları güncelledim. Deneyiniz.

. . .