如何让VBA代码复制数据到其他工作表时不再覆盖内容？

你的宏出现覆盖目标行的核心原因有两个：

1. 粘贴位置错误：原代码中Worksheets("CompletedV2").Range("A" & Rows.Count).End(3)(1)定位到的是目标表A列最后一个非空单元格本身，而非其下方的空行，导致每次复制的内容都会覆盖同一位置。
2. 未限定工作表的行数范围：Rows.Count默认指向当前活动工作表的行数，若活动表与目标表行数不一致（比如不同Excel版本的最大行数差异），可能导致定位偏差。

下面提供两种优化后的代码，按需选择：

方案1：循环逐行复制（保留原逻辑，修复定位问题） #

Option Compare Text
Sub move_rows_to_another_sheet()
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim myCell As Range
    
    ' 提前获取目标工作表引用，避免重复调用
    Set wsTarget = ThisWorkbook.Worksheets("CompletedV2")
    
    ' 计算目标表A列最后一个非空单元格的下一行（初始粘贴位置）
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
    
    For Each myCell In Selection.Columns(12).Cells
        If myCell.Value = "Yes" Then
            ' 复制到目标表的lastRow位置，然后更新lastRow
            myCell.EntireRow.Copy wsTarget.Range("A" & lastRow)
            lastRow = lastRow + 1 ' 每次复制后，下一次粘贴位置下移一行
        End If
    Next myCell
End Sub

方案2：批量复制（更高效，适合大量数据） #

如果选中的行数较多，批量复制比逐行循环效率更高：

Option Compare Text
Sub move_rows_to_another_sheet_batch()
    Dim wsTarget As Worksheet
    Dim copyRange As Range
    Dim myCell As Range
    
    Set wsTarget = ThisWorkbook.Worksheets("CompletedV2")
    
    ' 收集所有符合条件的行
    For Each myCell In Selection.Columns(12).Cells
        If myCell.Value = "Yes" Then
            If copyRange Is Nothing Then
                Set copyRange = myCell.EntireRow
            Else
                Set copyRange = Union(copyRange, myCell.EntireRow)
            End If
        End If
    Next myCell
    
    ' 如果有符合条件的行，一次性复制到目标表
    If Not copyRange Is Nothing Then
        Dim lastRow As Long
        lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
        copyRange.Copy wsTarget.Range("A" & lastRow)
    End If
End Sub

• 使用wsTarget.Rows.Count明确限定行数范围为目标工作表，避免跨表偏差。
• 提前计算初始粘贴位置，每次复制后更新行号（方案1），或批量收集后一次性粘贴（方案2），彻底解决覆盖问题。
• 用xlUp替代数字3，代码可读性更强（3是xlUp的常量值，但直接写枚举更清晰）。

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