使用 VBA 将空行复制到新工作表后删除 Excel 中的空行

Question

我已成功为 Excel 编写了一个 VBA 脚本，该脚本检查 A 列是否包含特定条目（在本例中为：2016），然后将整行复制到新工作表中。

唯一的问题是它将行复制到与原始工作表中完全相同的位置。因此，我在两者之间得到空行。我希望宏在复制这些空行后立即删除它们，或者将这些行一个接一个地复制到新工作表中。

Sub CopyRow()

Application.ScreenUpdating = False

Dim x As Long
Dim MaxRowList As Long
Dim S As String
Dim wsSource As Worksheet
Dim wsTarget As Worksheet


Set wsSource = ThisWorkbook.Worksheets("Tab 1")
Set wsTarget = ThisWorkbook.Worksheets("Tab 2")

aCol = 1
MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row

For x = 2 To MaxRowList
    If InStr(1, wsSource.Cells(x, 1), "2016") Then
    wsTarget.rows(x).Value = wsSource.rows(x).Value
    End If
Next

Application.ScreenUpdating = True

End Sub

感谢任何帮助。提前致谢。

Answer 1

您可以像这样为目标行设置一个变量：

Sub CopyRow()

Application.ScreenUpdating = False

Dim x As Long
Dim MaxRowList As Long
Dim S As String
Dim wsSource As Worksheet
Dim wsTarget As Worksheet


Set wsSource = ThisWorkbook.Worksheets("Tab 1")
Set wsTarget = ThisWorkbook.Worksheets("Tab 2")

aCol = 1
MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row

destiny_row = 2 
For x = 2 To MaxRowList
    If InStr(1, wsSource.Cells(x, 1), "2016") Then
    wsTarget.rows(destiny_row).Value = wsSource.rows(x).Value
    destiny_row = destiny_row +1
    End If
Next

Application.ScreenUpdating = True

End Sub

这样，它将开始复制目标工作表第 2 行中的这些值，并将根据 if 条件增加。告诉我它是怎么回事...

Answer 2

Sub CopyRow()

    Application.ScreenUpdating = False

    Dim x As Long
    Dim MaxRowList As Long, PrintRow as Long
    Dim S As String
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet


    Set wsSource = ThisWorkbook.Worksheets("Tab 1")
    Set wsTarget = ThisWorkbook.Worksheets("Tab 2")

    aCol = 1
    MaxRowList = wsSource.Cells(rows.Count, aCol).End(xlUp).Row

    For x = 2 To MaxRowList
        If InStr(1, wsSource.Cells(x, 1), "2016") Then
            PrintRow = wsTarget.range("A" & wsTarget.rows.count).end(xlup).row
            wsTarget.rows(PrintRow).Value = wsSource.rows(x).Value
        End If
    Next

    Application.ScreenUpdating = True

End Sub

Answer 3

您可以使用AutoFilter 方法，这样您就无需使用For 循环遍历所有行，只需将整个过滤范围复制到“Tab 2”工作表即可。

代码（cmets内的解释）

Option Explicit

Sub CopyRow()

Application.ScreenUpdating = False

Dim x As Long
Dim MaxRowList As Long
Dim MaxCol As Long

Dim S As String
Dim aCol As Long
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim SourceRng As Range
Dim VisRng As Range
Set wsSource = ThisWorkbook.Worksheets("Tab 1")
Set wsTarget = ThisWorkbook.Worksheets("Tab 2")

aCol = 1

With wsSource
    MaxRowList = .Cells(.Rows.Count, aCol).End(xlUp).Row ' find last row
    MaxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column ' find last column

    Set SourceRng = .Range(.Cells(1, 1), .Cells(MaxRowList, MaxCol)) ' set source range to actually occupied range

    .Range("A1").AutoFilter ' use AutoFilter method
    SourceRng.AutoFilter Field:=1, Criteria1:="2016"

    Set VisRng = SourceRng.SpecialCells(xlCellTypeVisible) ' set range to filterred range

    VisRng.Copy ' copy entire visible range
    wsTarget.Range("A2").PasteSpecial xlPasteValues ' past with 1 line
End With

Application.ScreenUpdating = True

End Sub