günü geleni aktar

[esref55]

arkadaşlar ekli dosyadaki mevcut sayfasında bitiş tarihi günün tarihinden önce veya günün tarihine eşit olan satırları arşiv sayfasındaki satırlara ilave etmek istiyorum.benzer makrolar buldum fakat uyarlayamadım. yardımcı olursanız memnun olurum. ilginize teşekkür ederim.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Long, sat As Long
Sheets("MEVCUT").Select
sat = Sheets("ARSIV").Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
For i = 2 To Cells(65536, "A").End(xlUp).Row
    If sat >= 65533 Then
        MsgBox "Satır doldu .Başka Kayıt yapamazsınız..!!", vbCritical, "DİKKAT"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    If Cells(i, "E").Value <= Date Then
        adr1 = Range(Cells(i, "A"), Cells(i, "E")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "E")).Address
        Sheets("ARSIV").Range(adr2).Value = Range(adr1).Value
        sat = sat + 1
    End If
Next i
Application.ScreenUpdating = True
Sheets("ARSIV").Select
MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[esref55]

Sayın Evren Gizlen
tam istediğim gibi olmuş. birde aktarılan satırları mevcut sayfasından silebilirmi. teşekkür ederim.

 

[Orion1]

Sayın Evren Gizlen
tam istediğim gibi olmuş. birde aktarılan satırları mevcut sayfasından silebilirmi. teşekkür ederim.

Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Long, sat As Long
Sheets("MEVCUT").Select
sat = Sheets("ARSIV").Cells(65536, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
For i = Cells(65536, "A").End(xlUp).Row To 2 Step -1
    If sat >= 65533 Then
        MsgBox "Satır doldu .Başka Kayıt yapamazsınız..!!", vbCritical, "DİKKAT"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    If Cells(i, "E").Value <= Date Then
        adr1 = Range(Cells(i, "A"), Cells(i, "E")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "E")).Address
        Sheets("ARSIV").Range(adr2).Value = Range(adr1).Value
        Range(adr1).Delete (xlUp)
        sat = sat + 1
    End If
Next i
Application.ScreenUpdating = True
Sheets("ARSIV").Select
MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[esref55]

teşekkür ederim. ellerine sağlık.

 

[Orion1]

teşekkür ederim. ellerine sağlık.

Rica ederim.
İyi çalışmalar.

 

[tufan03]

Sayın Evren GİZLEN aktarılan satırların mevcut sayfasından silinmesini sağlayabilirmiyiz.

 

[Orion1]

Sayın Evren GİZLEN aktarılan satırların mevcut sayfasından silinmesini sağlayabilirmiyiz.

4 numaralı mesajımda zaten bu işlem yapılıyor.

 

[tufan03]

Özür dilerim dikkat etmemiştim.