Mükerrer verilerin karşısındaki değerleri toplayıp ve teke indirdikten sonra aktarmak

[numan şamil]

Merhaba arkadaşlar
ekli dosyada izahını yapmaya çalıştım
kısaca sayfa2de "A" sutununda bulunan mükerer verilerin karşıllarındaki("B") sutunundaki verileri toplayacak ve teke indirecek mükerrer olmayan verileri olduğu gibi sayfa2 ye aktarmak istiyorum yardımlarınızı bekliyorum

 

[Orion1]

Dosyanız ektedir.

Sub teke59()
Dim sat2 As Long, sat1 As Long, sh As Worksheet, i As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat1 = 2
Range("A:B").Clear
Application.ScreenUpdating = False
For i = 2 To sat2
    If WorksheetFunction.CountIf(sh.Range("A2:A" & i), sh.Cells(i, "A").Value) = 1 Then
        Cells(sat1, "A").Value = sh.Cells(i, "A").Value
        Cells(sat1, "B").Value = WorksheetFunction.SumIf _
            (sh.Range("A2:A" & sat2), sh.Cells(i, "A").Value, sh.Range("B2:B" & sat2))
            sat1 = sat1 + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem  tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com" _
    , vbOKOnly + vbInformation, Application.UserName
End Sub

 

[numan şamil]

Dosyanız ektedir.

Sub teke59()
Dim sat2 As Long, sat1 As Long, sh As Worksheet, i As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat1 = 2
Range("A:B").Clear
Application.ScreenUpdating = False
For i = 2 To sat2
    If WorksheetFunction.CountIf(sh.Range("A2:A" & i), sh.Cells(i, "A").Value) = 1 Then
        Cells(sat1, "A").Value = sh.Cells(i, "A").Value
        Cells(sat1, "B").Value = WorksheetFunction.SumIf _
            (sh.Range("A2:A" & sat2), sh.Cells(i, "A").Value, sh.Range("B2:B" & sat2))
            sat1 = sat1 + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem  tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com" _
    , vbOKOnly + vbInformation, Application.UserName
End Sub

Sn Orion1 çok teşekkür ederim