birden fazla aynı kayıtlara denk gelen sayıları toplama ve başka sayfaya yazma

[xxxunsoulxxx]

arkadaşlar merhaba saatlerdir bakmama rağmen istediğim gibi bir şey bulamadım.
Ekte yüklemiş olduğum örnekte bulduğum kodu uyguladım sayfa 1 deki kayıtların toplamı sayfa 2 deki isimleri
bulup yanlarına yazdırmaya çalıştım fakat beceremedim. Şu anki bulunan makroda
sayfa 2 deki isimlerin üstüne tekrar kayıt yapıyor. benim istediğim isimler sabit kalacak sadece toplamlar değişecek bunu yapabilecek bir arkadaş var mı veya başka alternatif bir makro örneği verebilecek arkadaş varmı yardımlarını bekliyorum..

 

[Orion1]

dosyanız ektedir.

Sub toplamlar_59()
Dim deg As Double, i As Long, sat1 As Long, sh As Worksheet
Dim sat2 As Long, say As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
sat1 = Cells(Rows.Count, "B").End(xlUp).Row
If sat1 < 2 Then
    MsgBox "Sayfa1de B sütununda veri yok.İşlem İptal oldu", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Sheets("B2").Select
    Exit Sub
End If
Set sh = Sheets("Sayfa2")
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
If sat2 < 2 Then
    MsgBox "Sayfa2de A sütununda veri yok.İşlem İptal oldu", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Sheets("B2").Select
    Exit Sub
End If
sh.Range("B2:B" & sat2).ClearContents
For i = 2 To sat2
    deg = WorksheetFunction.SumIf(Range("B2:B" & sat1), sh.Cells(i, "A").Value, Range("N2:N" & sat1))
    sh.Cells(i, "C").Value = deg
Next i
sh.Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"

    
End Sub

 

[xxxunsoulxxx]

çok sağol allah senden razı olsun.