满足条件时将Excel数据复制到新工作表的VBA代码问题排查

问题描述 #

尝试用VBA将Excel中To_Do工作表里标记为“Complete”的数据转移到Done工作表，但现有代码存在问题：复制的数据总是重复覆盖Done工作表的B行，需要实现将数据复制到Done工作表的新行（B、C、D、E等列所在的新行）。

原代码如下：

Sub Move_When_Completed()
'Created by Excel 10 Tutorial
    
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long

    A = Worksheets("To_Do").UsedRange.Rows.Count
    B = Worksheets("Done").UsedRange.Rows.Count

    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Done").UsedRange) = 0 Then B = 0
    End If

    Set xRg = Worksheets("To_Do").Range("E1:E" & A)

    On Error Resume Next
    
    Application.ScreenUpdating = False
    
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "Complete" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Done").Range("A" & Rows.Count).End(xlUp).Offset(1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "Complete" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next

    Application.ScreenUpdating = True

End Sub

问题根源 #

• 正序循环删除行导致索引混乱：从第一行到最后一行循环时，删除行后后续行的索引会前移，导致部分行被跳过，错误的索引判断会让代码重复写入同一行。
• 冗余的行数变量维护：手动维护Done工作表的行数容易出错，不如动态获取最后一行可靠。
• 无效的二次判断逻辑：删除行后xRg(C)已指向新行，此时的判断毫无意义，还可能引发错误。
• 错误隐藏机制：On Error Resume Next掩盖了删除行后索引越界的问题，导致故障难以排查。

修正后的代码 #

Sub Move_When_Completed()
    Dim xRg As Range
    Dim lastRowToDo As Long
    Dim lastRowDone As Long
    Dim C As Long

    ' 获取To_Do工作表E列的最后一行
    lastRowToDo = Worksheets("To_Do").Cells(Rows.Count, "E").End(xlUp).Row
    Set xRg = Worksheets("To_Do").Range("E1:E" & lastRowToDo)

    Application.ScreenUpdating = False

    ' 倒序循环，避免删除行后索引错位
    For C = xRg.Count To 1 Step -1
        If CStr(xRg(C).Value) = "Complete" Then
            ' 获取Done工作表A列的最后一行（要从B列开始粘贴就把"A"改成"B"）
            lastRowDone = Worksheets("Done").Cells(Rows.Count, "A").End(xlUp).Row
            ' 处理Done工作表为空的边界情况
            If lastRowDone = 1 And Worksheets("Done").Cells(1, "A").Value = "" Then
                lastRowDone = 0
            End If

            ' 复制整行到Done工作表的新行
            xRg(C).EntireRow.Copy Destination:=Worksheets("Done").Range("A" & lastRowDone + 1)
            ' 删除原行
            xRg(C).EntireRow.Delete
        End If
    Next C

    Application.ScreenUpdating = True
End Sub

关键修改说明 #

• 倒序循环：从最后一行往第一行遍历，删除行后不会影响未处理的行索引，彻底避免跳过或重复处理问题。
• 动态获取最后一行：通过Cells(Rows.Count, 列).End(xlUp).Row实时获取目标工作表的最后一行，同时处理了目标表为空的特殊情况，比手动维护变量更可靠。
• 精简冗余逻辑：移除了无效的二次判断和错误隐藏语句，让代码逻辑更清晰，便于后续维护和排查问题。
• 灵活调整粘贴起始列：如果需要从Done工作表的B列开始粘贴数据，只需将代码中Range("A" & lastRowDone + 1)的"A"替换为"B"即可。

内容的提问来源于stack exchange，提问作者user28058090