Yıla Göre Yeni Sayfa Açma ve Aktarma İşlemi

[canercaneryilmaz]

Merhaba Hocalarım.
Başlıkta da belirttiğim gibi yıla göre sayfa açılmasını ve aktarım yapmasını istiyorum. Örnek dosyayı ekledim.
Saygılarımla.

İndir tarihe göre sayfa açma aktarma

Dosyayı indir tarihe göre sayfa açma aktarma

dosya.co

 

[Ömer]

Merhaba,

Deneyiniz.

Sub yil_aktar()

    Dim S1 As Worksheet, S2 As Worksheet, sat As Long, sut As Integer
    Dim syf As String, i As Long, sh As Worksheet

    Set S1 = Sheets("anasayfa")
    Set S2 = Sheets("örnek")
    sut = Sheets("örnek").Cells(1, Columns.Count).End(xlToLeft).Column
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each sh In Worksheets
        If sh.Name <> S1.Name And sh.Name <> S2.Name Then
            sh.Delete
        End If
    Next

    For i = 2 To S1.Cells(Rows.Count, "B").End(xlUp).Row
        syf = Format(S1.Cells(i, "B"), "yyyy")
        If Not varmi(syf) Then
            Sheets("örnek").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = syf
        End If
        sat = Sheets(syf).Cells(Rows.Count, "A").End(xlUp).Row + 1
        Sheets(syf).Cells(sat, "A") = sat - 1
        S1.Cells(i, "B").Resize(1, sut - 1).Copy Sheets(syf).Cells(sat, "B")
        Sheets(syf).Cells.EntireColumn.AutoFit
    Next i

End Sub
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.