Diğer sayfalara toplamlı aktarma

[hunter123]

Hayırlı sabahlar arkadaşalar,
Sayfalar arası aktarım işleminde sorun yaşıyorum. "Rapor2" adlı sayfamda N sütunu dahil verilerim vardır. N sütunundaki kaç adet üretim cinsi varsa yan sayfalar oluşuyor. Aktarım yapılacak sütunlar A,D,K,L,M'dir. Hepsi aktarılmayacak.(Bunu beceremedim) A,D,K ve M yan yana ama L sütunu O sütununa aktarılacak. Ayrıca A sütununda tarihler var. Diğer D,K,Lve M sütunları aktarılırken A sütunundaki aynı ayda olan veriler toplama işlemi yapıldıktan sonra geliyor. (Bunu da beceremedim.) Şimdiden Teşekkürler...

Sub aktar()
On Error Resume Next
Application.Run "sayfasilme"
Application.Run "benzersiz"
Application.Run "sayfaismiolusma"


Dim i As Long
For i = 4 To Sheets("Rapor2").range("a65536").End(3).Row
Set sayfa = Sheets(Sheets("Rapor2").Cells(i, "n").Value)
If Not sayfa Is Nothing Then
Sheets("Rapor2").Rows(i).Copy Sheets(sayfa.Name).range("a65536").End(3)(2, 1)
End If
Next i
range("A1").Select
MsgBox "Aktarımlar tamamlanmıştır.  "
i = Empty

End Sub

Sub sayfaismiolusma()
'sayfa ismi oluşturma
On Error Resume Next
Dim i As Integer
For i = 4 To Worksheets("Rapor2").range("a65536").End(3).Row
If Cells(i, 15).Value > 0 Then
Sheets.Add
ActiveSheet.Name = Worksheets("Rapor2").Cells(i, 15).Value
Sheets("Rapor2").Select
End If
Next i

i = Empty
    Columns("O:O").Select
    Selection.ClearContents
End Sub

Sub sayfasilme()
'rapor2 harici sayfaları silme
Application.DisplayAlerts = False
For Each Sf In Worksheets
If Sf.Name <> "Rapor2" Then Sf.Delete
Next
Application.DisplayAlerts = True
End Sub
Sub benzersiz()
Dim sat As Long, sat2 As Long, i As Long
sat = Sheets("Rapor2").Cells(65536, "n").End(xlUp).Row
sat2 = 4
For i = 4 To sat
    If WorksheetFunction.CountIf(Sheets("Rapor2").range("n4:n" & i), _
    Sheets("Rapor2").Cells(i, "n")) = 1 Then
        Sheets("Rapor2").Cells(sat2, "o").Value = Sheets("Rapor2").Cells(i, "n").Value
        sat2 = sat2 + 1
    End If
Next


   
End Sub