如果单元格与整个工作表的值匹配，VBA复制整行

Question

我试图有一个更新按钮，它检查 H 列中的单元格的值“未启动”或“关闭”并将这些单元格剪切/粘贴到相应的工作表。我目前拥有的代码并没有处理每个单元格，并且只将一行复制到每张纸上。

截图：

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim lastRow As Long
    Dim Cell As Range

'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

'Select Entire Row
    Selection.EntireRow.Select

'Move row to destination sheet & Delete source row
    lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
    lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
    lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row

    With sht2
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If Cell.Value = "Not started" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
            .Rows(Cell.Row).Delete

        ElseIf Cell.Value = "Closed" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
            .Rows(Cell.Row).Delete

        End If
     Next Cell

    End With

    MsgBox "Update Done!"

End Sub

Answer 1

通常，当您需要根据条件删除行时，您应该使用计数器变量并循环遍历reverse order 中的单元格。

但是，如果您使用范围/单元格对象循环遍历单元格，则不应在将行复制到另一张表后立即删除该行。相反，您应该声明一个范围变量并存储符合行删除条件的所有单元格的地址，并在最后一次将它们全部删除。

在这种情况下，Autofilter 是一个理想的候选对象。

请尝试您的原始代码的调整版本。

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
    Dim Cell As Range
    Dim RngToDelete As Range

    Application.ScreenUpdating = False
'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

'Select Entire Row
    'Selection.EntireRow.Select

'Move row to destination sheet & Delete source row
    lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
    lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
    lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row

    With sht2
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If Cell.Value = "Not started" Then
            If RngToDelete Is Nothing Then
                Set RngToDelete = Cell
            Else
                Set RngToDelete = Union(RngToDelete, Cell)
            End If
            lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
            '.Rows(Cell.Row).Delete

        ElseIf Cell.Value = "Closed" Then
            If RngToDelete Is Nothing Then
                Set RngToDelete = Cell
            Else
                Set RngToDelete = Union(RngToDelete, Cell)
            End If
            lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
            '.Rows(Cell.Row).Delete

        End If
     Next Cell

    End With

    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
    Application.CutCopyMode = 0
    Application.ScreenUpdating = True
    MsgBox "Update Done!"

End Sub

Answer 2

编辑：根据评论将 sht 更正为 sht2

从Collection 中删除项目时（如Range 中的行），您应该从下到上进行，避免跳过项目和处理不存在的项目

此外，您的代码没有更新“tagret”表的lastRow(n)

请考虑以下代码（未经测试，但已注释）

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim iRow As Long

'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

    With sht2
        With Range("H1", .Cells(.Rows.Count, "H").End(xlUp)) 'reference its column H from row 1 down to last not empty one
            iRow = .Rows.Count 'initialize row index from the bottom
            Do
                With .Cells(iRow, 1) 'reference referenced range cell in its current row
                    Select Case .Value
                        Case "Not started"
                            .Rows(iRow).Copy Destination:=sht1.Cells(sht1.Rows.Count, "A").End(xlUp)
                            .Rows(iRow).Delete

                        Case "Closed"
                            .Rows(iRow).Copy Destination:=sht3.Cells(sht3.Rows.Count, "A").End(xlUp)
                            .Rows(iRow).Delete
                    End Select
                End With
                iRow = iRow - 1
             Loop While iRow >= 1
        End With
    End With

    MsgBox "Update Done!"

End Sub