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

您可以使用AutoFilter方法，它可以节省您在所有行中使用For循环的需要，只需将整个过滤范围复制到“标签2”工作表。< / p>

代码（评论内注释）

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

Answer 3

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

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

3 个答案: