Aşağıdaki kodu boş bir modüle uygulayıp deneyiniz.
Kod çalışırken ilk olarak size daha önce aktarım yaptığınız sayfaları silmek istiyormusunuz diye soracak evet derseniz önceki aktarım yapılan sayfalar silinecek. Hayır derseniz varolan sayfaların alt satırlarına devam ederek aktarım yapacaktır.
Kod:
Option Explicit
Sub AKTAR()
Dim S1, S2, S3, Sayfa, X, Satir
If MsgBox("Daha önce aktardığınız sayfaları silmek istiyor musunuz?", vbCritical + vbYesNo) = vbNo Then GoTo 10
Application.DisplayAlerts = False
For Each Sayfa In ThisWorkbook.Worksheets
If Sayfa.Name <> "Data" Then Sayfa.Delete
Next
Application.DisplayAlerts = True
10 Application.ScreenUpdating = False
Set S1 = Sheets("Data")
S1.Range("F1:F" & Rows.Count).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Cells(1, Columns.Count), Unique:=True
For X = 2 To S1.Cells(Rows.Count, Columns.Count).End(3).Row
S1.Range("A1").AutoFilter Field:=6, Criteria1:=S1.Cells(X, Columns.Count)
If Sayfa_Kontrol(S1.Cells(X, Columns.Count)) Then
Set S2 = Sheets(S1.Cells(X, Columns.Count).Text)
Satir = S2.Cells(Rows.Count, 1).End(3).Row + 1
If S1.Cells(Rows.Count, 1).End(3).Row > 1 Then
S1.Range("A2:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 1)
S1.Range("Y2:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 7)
S1.Range("BE2:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 8)
S1.Range("BH2:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 10)
S1.Range("BL2:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 11)
S2.Range("A2:K" & Rows.Count).Sort Key1:=S2.Range("I2"), Order1:=xlAscending
End If
Else
Set S3 = Sheets.Add
S3.Move After:=Worksheets(Worksheets.Count)
S3.Name = S1.Cells(X, Columns.Count)
S1.Range("A1:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 1)
S1.Range("Y1:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 7)
S1.Range("BE1:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 8)
S1.Range("BH1:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 10)
S1.Range("BL1:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 11)
S3.Range("A2:K" & Rows.Count).Sort Key1:=S3.Range("I2"), Order1:=xlAscending
End If
Next
S1.Select
S1.Cells(1, Columns.Count).EntireColumn.Delete
S1.Range("A1").AutoFilter Field:=6
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Function Sayfa_Kontrol(Sayfa_Adi As String) As Boolean
On Error Resume Next
Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa_Adi).Name > 0))
End Function