Koşula Göre Satır Kopyalama

[steppe]

Merhaba Arkadaşlar,
Bu sitedeki hocalarımın yardımıyla aşağıdaki kodla koşula göre kopyalama yapılabiliyor. Yalnız sayfa1'den Sayfa2'ye kopyalayınca Sayfa2 deki verileri siliyor. İstediğim kopyalama yapınca Sayfa2 deki verileri silmeden ilk boş hücreden itibaren kopyalama için yardımlarınız bekliyorum.

Sub aktar()
Dim sat1 As Long, sh As Worksheet, sat2 As Long
Dim j As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "D").End(xlUp).Row
sat2 = 2
For j = 2 To sat1
If Cells(j, "D").Value = "Adana" Or Cells(j, "D").Value = "Ankara" Then
Range("A" & j & ":F" & j).Cut sh.Range("A" & sat2)
sat2 = sat2 + 1
End If
Next j
Application.CutCopyMode = True
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
With Columns(1)
.Replace Chr(160), ""
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodları deneyin.

Sub aktar()
    Dim sat1 As Long, sh As Worksheet, sat2 As Long
    Dim j As Long
    Sheets("Sayfa1").Select
    Set sh = Sheets("Sayfa2")
    Application.ScreenUpdating = False
    sat1 = Cells(Rows.Count, "D").End(xlUp).Row
        For j = 2 To sat1
        If Cells(j, "D").Value = "Adana" Or Cells(j, "D").Value = "Ankara" Then
            sat2 = sh.Cells(Rows.Count, "D").End(xlUp).Row + 1
            Range("A" & j & ":F" & j).Cut sh.Range("A" & sat2)
        End If
    Next j
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
    sh.Select
    Set sh = Nothing
    With Columns(1)
            .Replace Chr(160), ""
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

 

[steppe]

Hocam,
Yardımlarınız için çok teşekkür ederim.

 

[Muzaffer Ali]

Rica ederim. İyi çalışmalar.