Satır dolu ise kopyala

[Szg15]

Merhabalar. Sayfa1’deki D2:H aralığından F2:F sütunu dolu olanları, Sayfa2’nin B2:F aralığına kopyalayıp yapıştırmasını istiyorum. Yardımcı olur musunuz?

 

[Ziynettin]

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("B2:F" & Rows.Count).ClearContents
son = s1.Cells(Rows.Count, "f").End(3).Row
If son < 2 Then Exit Sub
    tbl = s1.Range("D1:H" & son).Value

    For i = 2 To UBound(tbl)
        If tbl(i, 3) <> "" Then
            s = s + 1
            For j = 1 To UBound(tbl, 2)
                tbl(s, j) = tbl(i, j)
            Next j
        End If
    Next i
    
    If s > 0 Then
        s2.[B2].Resize(s, UBound(tbl, 2)) = tbl
        MsgBox "İşlem bitti.", vbInformation
    Else
        MsgBox "Yazdırılacak veri bulunamdı.", vbCritical
    End If
End Sub

 

[Szg15]

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("B2:F" & Rows.Count).ClearContents
son = s1.Cells(Rows.Count, "f").End(3).Row
If son < 2 Then Exit Sub
    tbl = s1.Range("D1:H" & son).Value

    For i = 2 To UBound(tbl)
        If tbl(i, 3) <> "" Then
            s = s + 1
            For j = 1 To UBound(tbl, 2)
                tbl(s, j) = tbl(i, j)
            Next j
        End If
    Next i
    
    If s > 0 Then
        s2.[B2].Resize(s, UBound(tbl, 2)) = tbl
        MsgBox "İşlem bitti.", vbInformation
    Else
        MsgBox "Yazdırılacak veri bulunamdı.", vbCritical
    End If
End Sub

Çok teşekkür ederim Ziynettin Bey. Elleriniz dert görmesin.

 

[Szg15]

Hocam Sayfa3’ün I3:M3 aralığından itibaren aşağıya doğru kaç satır dolu ise, bunları da Sayfa2’nin B2:F aralığına (Sayfa1’den gelenlerin hemen altından itibaren) kopyalayıp yapıştırabilir misiniz?