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 to sht2

从Collection删除项目时（就像Range中的行一样），您应该从下到上进行操作，避免同时跳过项目并处理不存在的项目

此外，您的代码没有更新lastRow(n)＆＃34; tagret＆＃34;片

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

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

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

2 个答案: