Seçili yıla ait kayıtları arşive aktarma

[mkuru28]

Merhaba arkadaşlar.
Ekli örnek dosyada detaylı olarak anlattığım gibi kurum resmi araç görev kayıtlarını tuttuğum bir çalışma kitabım var. Bu çalışma kitabında verileri DEFTER isimli sayfaya işliyorum. Yıl bitince önceki yıllara ait kayıtları arşive aktarmak istiyorum. Burada yapmak istediğim birçok yıla ait kayıtlar arasından seçtiğim yıla ait olan kayıtları arşivlemek istiyorum. Örnek çalışma kitabı ektedir. Yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim.

Örnek dosya

 

[MGokboruAtan]

kontrol eder misiniz eğer doya indiremiyorsanız bu kodu ekleyin

Sub secili_yili_arsive_aktar()

    Dim ws As Worksheet
    Dim arsiv As Worksheet
    Dim yil As Integer
    Dim i As Integer
    
    ' Hedef yılı belirle
    yil = Range("F2").Value
    
    ' Arşiv sayfasını belirle
    Set arsiv = Sheets("ARŞİV")
    
    ' Hedef yılı kontrol et ve arşive taşı
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "ARŞİV" Then
            For i = 100 To 5 Step -1
                If ws.Range("K" & i).Value = yil Then
                    ws.Rows(i).Copy arsiv.Rows(arsiv.Cells(arsiv.Rows.Count, "B").End(xlUp).Row + 1)
                    ws.Rows(i).Delete
                End If
            Next i
        End If
    Next ws
End Sub

 

[muygun]

Merhaba;
Alternatif olsun.
Deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server18/2n2oze/mkuru28-secili_yili_aktarma_ve_geri_alma.zip.html

 

[mkuru28]

Çok teşekkür ederim arkadaşlar. İyi ki varsınız.

 

[veyselemre]

Sub secili_yili_arsive_aktar()
    Dim son&, yil
    With Sheets("DEFTER")
        yil = .Range("F2").Value
        If yil <> "" Then
            son = .Cells(Rows.Count, 2).End(3).Row
            With .Range("B4:M" & son)
                .AutoFilter Field:=10, Criteria1:=yil
                If Evaluate("SUBTOTAL(3,B5:B" & son & ")") > 1 Then
                    .Rows(2 & ":" & son - 3).Copy Sheets("ARŞİV").Cells(Rows.Count, 2).End(3).Offset(1)
                    .Rows(2 & ":" & son - 3).Delete shift:=xlUp
                End If
                .AutoFilter
            End With
        End If
    End With
End Sub