toplam aldırma ve veri aktarımı

[baygal]

merhabalar , ekteki örnek sayfada yapmak istediğimi anlatmaya çalıştım..yardımcı olursanız çok makbule geçecek..şimdiden çok teşekkürler...

 

[Orion1]

Dosyanız ektedir.

Sub bolumle_59()
Dim sat As Long, i As Long, k As Range, s1 As Worksheet, s3 As Worksheet
Dim sat11 As Long, sat2 As Long, bolum As String, s4 As Worksheet
Sheets("Sayfa2").Select
Range("L3:O65536").ClearContents
Set s1 = Sheets("VERİ")
Set s3 = Sheets("Detaylar")
Set s4 = Sheets("Toplamlar")
sat11 = s1.Cells(65536, "A").End(xlUp).Row
sat2 = Cells(65536, "K").End(xlUp).Row
sat3 = s3.Cells(65536, "A").End(xlUp).Row + 1
sat4 = s4.Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
sat = Cells(65536, "C").End(xlUp).Row
For i = 4 To sat
    Set k = s1.Range("A2:A" & sat11).Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then bolum = k.Offset(0, 1).Value
    Set k = Range("K2:K" & sat2).Find(bolum, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(k.Row, "L").Value = Cells(k.Row, "L").Value + Cells(i, "E").Value
        Cells(k.Row, "M").Value = Cells(k.Row, "M").Value + Cells(i, "H").Value
    End If
Next i
If sat + sat3 > 65533 Then
    MsgBox "Detaylar sayfasında Yer kalmadı." & vbLf & _
    "Detaylar aktarılmadı", vbCritical, "UYARI"
    Else
    Range("C4:I" & sat).Copy s3.Range("A" & sat3)
    Range("C4:I" & sat).ClearContents
End If
If sat2 + sat4 > 65533 Then
    MsgBox "Toplamlar sayfasında Satır doldu" & vbLf & _
    "Toplamlar aktarılmadı", vbCritical, "UYARI"
    Else
    Range("K3:O" & sat2).Copy s4.Range("A" & sat4)
    Range("K3:O" & sat2).ClearContents
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub