VBA宏粘贴覆盖数据求助：实现指定列空行粘贴及自动编号

问题诊断 #

原宏的核心问题：

• D列空行定位逻辑错误，依赖End(xlDown)会在中间有空行时停住，导致误判空行位置
• 仅通过单次判断处理C列已有数据的情况，无法彻底避免覆盖
• 缺少自动编号的实现逻辑

修复后的完整代码 #

Sub CopyPasteToAnotherSheet()
    Dim sourceRange As Range
    Dim parkingSheet As Worksheet
    Dim firstEmptyDRow As Long
    Dim targetRow As Long
    Dim maxID As Long
    
    ' 检查是否选中有效范围
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选中要复制的内容！", vbExclamation
        Exit Sub
    End If
    Set sourceRange = Selection
    Set parkingSheet = ThisWorkbook.Sheets("PARKING")
    
    ' 从D列底部向上查找，定位首个空行（规避中间空行干扰）
    firstEmptyDRow = parkingSheet.Cells(parkingSheet.Rows.Count, "D").End(xlUp).Row + 1
    ' 确保起始行不小于第18行
    If firstEmptyDRow < 18 Then firstEmptyDRow = 18
    targetRow = firstEmptyDRow
    
    ' 循环检查C列是否有数据，有则插入新行
    Do While parkingSheet.Range("C" & targetRow).Value <> ""
        parkingSheet.Rows(targetRow).Insert Shift:=xlDown
        targetRow = targetRow + 1
    Loop
    
    ' 自动生成连续编号（示例编号列为A列）
    On Error Resume Next
    maxID = Application.WorksheetFunction.Max(parkingSheet.Range("A:A"))
    On Error GoTo 0
    parkingSheet.Range("A" & targetRow).Value = IIf(maxID = 0, 1, maxID + 1)
    
    ' 粘贴内容到目标行C列
    sourceRange.Copy
    parkingSheet.Range("C" & targetRow).PasteSpecial xlPasteValues
    Application.CutCopyMode = False ' 清除复制状态
End Sub

关键修复说明 #

• 精准定位D列空行：改用从D列最后一行向上查找的方式，彻底避免中间空行导致的误判，确保找到真正的末尾空行。同时强制起始行不小于18，符合原需求的初始范围。
• 彻底避免覆盖：使用Do While循环持续检查目标行C列状态，只要有数据就插入新行，直到找到空白的C列单元格。
• 自动编号实现：通过取编号列的最大值加1生成连续编号，加入错误处理避免无数据时的报错；如果编号列不是A列，直接替换代码中的列标识即可。
• 基础校验：增加选中内容的有效性检查，防止无选中内容时宏报错。

自定义调整 #

• 如果编号列不是A列，将代码中Range("A:A")和Range("A" & targetRow)替换为目标列（比如B列则写成"B:B"）。
• 如果D列的起始检查行不是18，修改If firstEmptyDRow < 18 Then firstEmptyDRow = 18中的数字即可。

内容的提问来源于stack exchange，提问作者Gonçalo Rocha