Başka Bir Sayfaya Koşullu Aktarma

[vitalexx]

Arkadaşlar forumda gerekli aramaları yaptım ancak, seviyem yetersiz olduğu için aynı amaca ulaşmama yardım edecek bir ileti bulamadım. Öncelikle bunun için özür dilerim. Ekteki dosyadaki "geçerlilik tarihi" kriterine göre bir sıralama yapıp, "bugünden itibaren 60 günlük aralıktaki teminat mektuplarını" listelemek istiyorum. İlgilenirseniz sevinirim.

 

[veyselemre]

Sayfa2 ye listeleme yapar

Sub Suresi60GundenAzKalanlariListele()
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
son1 = s1.[a65536].End(3).Row

s2.Cells.Delete

s1.Select
sat = 5
For x = 5 To son1
    KalanGun = Cells(x, "G") - Date
    
    If KalanGun > 0 And KalanGun <= 60 Then
        For sut = 1 To 7
            s2.Cells(sat, sut) = Cells(x, sut)
        Next sut
        sat = sat + 1
    End If
Next x

Range("A5:G5").Copy
s2.Range("a6:g" & sat - 1).PasteSpecial Paste:=xlPasteFormats
Range("A4:G4").Copy s2.Range("A5:G5")
s2.Select
Cells.EntireColumn.AutoFit

End Sub

 

[vitalexx]

Teşekkür ederim. Kolay gelsin

 

[vitalexx]

Öğrenecek çok şey var

Sayın Veyselemre veya zamanı olan başka arkadaşlar, bu konuda bir yardım almıştım ama asıl tabloma uyarlamada sorun yaşadım. Şimdi Tablonun orjinali üzerinde makrodaki gerekli düzeltmeleri yapabilirmisiniz?
Dosyam ekte.

 

[veyselemre]

Sub Suresi60GundenAzKalanlariListele()
Set s1 = Sheets("TABLO")
Set s2 = Sheets("RAPOR")
son1 = s1.[a65536].End(3).Row

s2.Cells.Delete

s1.Select
sat = 4
For X = 4 To son1
    KALANGUN = Cells(X, "H") - Date 'H Sütununa göre kalan gün
    If KALANGUN > 0 And KALANGUN <= 60 Then
        s2.Range(s2.Cells(sat, "A"), s2.Cells(sat, "K")).Value = Range(Cells(X, "A"), Cells(X, "K")).Value
        sat = sat + 1
    End If
Next X

Range("A4:K4").Copy
s2.Range("a4:K" & sat - 1).PasteSpecial Paste:=xlPasteFormats
Range("A3:K3").Copy s2.Range("A3:K3")
s2.Select
Cells.EntireColumn.AutoFit

End Sub