Копировать Вставить код VBA с пустыми строками

Question

Приведенный ниже код выполняет поиск, копирует и вставляет найденные данные в другой лист. Тем не менее, есть пробелы, когда это делается в вставленном листе. Например: «Я хочу скопировать» в ячейке A1 и скопировать всю строку в указанный лист. Нашел «Быть ​​скопированным» в A4 и скопировал всю строку на указанный рабочий лист. Однако в вставленном листе есть две пустые строки между A1 и A4. Спасибо за вашу помощь.

Sub Deleting()
    Application.ScreenUpdating = False
    Dim wsh As Worksheet, i As Long, Endr As Long, x1 As Worksheet, p As Long
    Set wsh = ActiveSheet
    Worksheets.Add(Before:=Worksheets("Original Sheet")).Name = "Skipped"
    Set x1 = Worksheets("Skipped")
    Worksheets("ABC").Activate
    i = 2
    Endr = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
    While i <= Endr
        If Cells(i, "A") = "To Be Copied" Then
            wsh.Rows(i).Copy
            x1.Rows(i).PasteSpecial
            p = p + 1
            Endr = Endr + 1
        End If
        i = i + 1
    Wend
End Sub

Answer 1

Вам нужны два счетчика: i для исходных строк, j для целевых строк. Вы увеличиваете j только при копировании строки.

Answer 2

Ваш существующий код требует либо

1. Отдельный счетчик для положения записанной строки (точки резца) или
2. Вставка в последнюю использованную строку «Пропущено» с помощью xlUp для поиска последней использованной ячейки

Но лучше было бы копировать строки в одном кадре, используя AutoFilter. Что-то вроде ниже

Sub Quicker()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("ABC")
Set ws2 = Worksheets.Add(Before:=Worksheets("Original Sheet"))
'in case Skipped exists
On Error Resume Next
ws2.Name = "Skipped"
On Error GoTo 0
ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "To Be Copied"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
    Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
    rng1.EntireRow.Copy ws2.[a1]
End If
ws1.AutoFilterMode = False
MsgBox "Sheet " & ws2.Name & " updated"
End Sub