Excel VBA宏数据移动问题：如何实现无覆盖新行粘贴

我有两个VBA宏，用于在工作表间根据关键词completed和not completed移动数据，表格使用A至G列。现在运行宏时，偶尔会出现数据粘贴位置偏离现有数据，或者覆盖已有行的情况。我想要修改宏，实现粘贴到新行且不覆盖其他数据，尝试添加.Insert.Row语句后还是有覆盖或粘贴位置过远的问题。

原代码 #

工作表代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MoveToCompleted
        End If
    Next
    Application.EnableEvents = True
End Sub

MoveToCompleted宏代码 #

Sub MoveToCompleted()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Master").Range("C1:C" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "completed" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & B + 1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

MoveToMaster宏代码 #

Sub MoveToMaster()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Master").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Completed").Range("C1:C" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "not completed" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Master").Range("A1" & B + 1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "not completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

问题根源 #

1. UsedRange不可靠：UsedRange.Rows.Count会包含仅格式化过的空行，导致计算的目标行号偏离实际数据末尾。
2. 语法错误：MoveToMaster中Range("A1" & B + 1)是错误写法，多了一个1，导致行号计算错误。
3. 循环逻辑缺陷：从前往后循环删除行时，会导致后续单元格索引偏移，容易漏判或引用错误单元格。

修改后的代码 #

工作表代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    On Error GoTo Cleanup
    If Intersect(Target, Me.Range("C:C")) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        ' 直接判断关键词，替换原错误的>0逻辑
        If UCase(CStr(Target(Z).Value)) = "COMPLETED" Then
            MoveToCompleted
        End If
    Next Z

Cleanup:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "错误：" & Err.Description
End Sub

MoveToCompleted宏代码 #

Sub MoveToCompleted()
    Dim wsMaster As Worksheet, wsCompleted As Worksheet
    Dim lastRowMaster As Long, lastRowCompleted As Long
    Dim i As Long
    
    Set wsMaster = ThisWorkbook.Worksheets("Master")
    Set wsCompleted = ThisWorkbook.Worksheets("Completed")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 精准获取数据最后一行，避免空格式行干扰
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, "C").End(xlUp).Row
    lastRowCompleted = wsCompleted.Cells(wsCompleted.Rows.Count, "A").End(xlUp).Row
    
    ' 从后往前循环，避免删除行后索引偏移
    For i = lastRowMaster To 1 Step -1
        If UCase(CStr(wsMaster.Cells(i, "C").Value)) = "COMPLETED" Then
            wsMaster.Rows(i).Copy Destination:=wsCompleted.Cells(lastRowCompleted + 1, "A")
            wsMaster.Rows(i).Delete
            lastRowCompleted = lastRowCompleted + 1
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

MoveToMaster宏代码 #

Sub MoveToMaster()
    Dim wsMaster As Worksheet, wsCompleted As Worksheet
    Dim lastRowMaster As Long, lastRowCompleted As Long
    Dim i As Long
    
    Set wsMaster = ThisWorkbook.Worksheets("Master")
    Set wsCompleted = ThisWorkbook.Worksheets("Completed")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row
    lastRowCompleted = wsCompleted.Cells(wsCompleted.Rows.Count, "C").End(xlUp).Row
    
    ' 从后往前循环
    For i = lastRowCompleted To 1 Step -1
        If UCase(CStr(wsCompleted.Cells(i, "C").Value)) = "NOT COMPLETED" Then
            wsCompleted.Rows(i).Copy Destination:=wsMaster.Cells(lastRowMaster + 1, "A")
            wsCompleted.Rows(i).Delete
            lastRowMaster = lastRowMaster + 1
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

关键改进点 #

• 用Cells(Rows.Count, Column).End(xlUp).Row替代UsedRange，精准定位数据真实末尾行。
• 改为从后往前循环，避免删除行后单元格索引偏移导致的漏处理。
• 修复MoveToMaster中的语法错误，确保粘贴位置正确。
• 替换On Error Resume Next为定向错误捕获，便于排查问题。
• 用UCase()统一大小写判断，避免因大小写不一致导致的判断失败。

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