Şarta göre süzüp diğer sayfaya verileri aktarma...

[manly]

Ekte gönderdiğim dosyada, "D" sütununda bulunan verileri, kırmızı renge boyadıklarımdan sadece 7,8,9 olan satırları süzüp dosya1'e aktarmak istiyorum. 1000 civarında sütun olduğunu düşünürek bir makro yazar mısınız? Yardımlarınızı bekliyorum..

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Dim sat As Integer
Dim s As Integer
Sayfa2.[a2:n65536].Clear
s = 2
    For sat = 2 To Sayfa1.Cells(65536, "d").End(xlUp).Row
        If Mid(Sayfa1.Cells(sat, "d"), 9, 1) Like "7" Or _
        Mid(Sayfa1.Cells(sat, "d"), 9, 1) Like "8" Or _
        Mid(Sayfa1.Cells(sat, "d"), 9, 1) Like "9" Then
            Sayfa1.Cells(sat, "a").EntireRow.Copy Sayfa2.Cells(s, "a")
            s = s + 1
        End If
    Next
End Sub

 

[manly]

Çok teşekkürler hocam, ellerinize sağlık....