Veri aktarımı

[sanal33]

Veri sayfasındaki bilgilerin sınıf/şube sütununa göre süzülerek yeni sayfa oluşturma ve bu sayfalara bilgilerin aktarılmasını nasıl yapabilirim?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, SAYFA As Worksheet, X As Integer
 
    Set S1 = Sheets("VERİ")
 
    Application.ScreenUpdating = False
 
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Name <> "VERİ" Then
            Application.DisplayAlerts = False
            SAYFA.Delete
            Application.DisplayAlerts = True
        End If
    Next
 
    With S1
        .Range("AA:AA").Clear
        .Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA2"), Unique:=True
        .Range("AA3:AA65536").Sort Key1:=.Range("AA3"), Order1:=xlAscending, Header:=xlGuess, _
         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        For X = 3 To .Cells(65536, "AA").End(xlUp).Row
            Sheets.Add.Move After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = .Cells(X, "AA").Value
            .Range("A2").AutoFilter Field:=2, Criteria1:=.Cells(X, "AA")
            .Cells.CurrentRegion.Copy Sheets(Sheets.Count).Range("A1")
            Sheets(Sheets.Count).Cells.EntireColumn.AutoFit
        Next
 
        .Select
        .Range("A2").AutoFilter Field:=2
        .Range("AA:AA").Clear
    End With
 
    Set S1 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[sanal33]

İlginize teşekkür ederim.