Excel VBA跨工作簿粘贴分批次数据时覆盖同行而非新增行

问题描述 #

• 实现目标：通过Excel VBA完成跨工作簿数据同步，将当前工作簿FORM.HDR 1.1工作表内分批次更新的4组源强度验证测量数据，同步至共享路径下的目标工作簿Postsource exchangeResults.xlsx的Result-1工作表。4组数据分别对应源表M、N、O、P列的M11:M12、N11:N12、O11:O12、P11:P12区域，会在不同日期分别完成测量后触发保存操作。
• 原有代码故障：每次执行粘贴时，代码通过Cells(Rows.Count, 列号).End(xlUp).Row + 1单独定位当前写入列的最后一个非空行，在新增行写入转置数据，不会匹配同一条记录的对应行位置，导致同一次源交换的多批次测量数据分散在不同行，首次保存数据正常，第二次及以后保存就会出现数据错位到新行的问题。
• 修复要求：
  • 分批次粘贴数据时，内容必须写入同一条记录的对应列，覆盖已有单元格内容，同批次所有测量结果最终保存在同一行，禁止生成多余空行、错位行
  • 全部保留原有业务逻辑：操作前解锁目标工作表、操作后重新保护工作表、仅粘贴数值、转置粘贴、4组数据全部保存完成后清空源表M11:P12区域、空值校验弹窗、保存成功提示弹窗

故障根因 #

原代码4组数据的写入逻辑完全独立，每写入一组数据就单独以当前列的最后非空行+1作为写入行，没有为整批次数据统一锚定固定的目标行：比如第一组M列数据写入时取A列最后一行+1，后续写N列数据时取C列最后一行+1，如果两个列的已填充行号不一致，就会把同批次数据写到不同行，直接造成错位。

修复后完整代码 #

Sub SyncSourceData()
    Dim dstWb As Workbook
    Dim dstWs As Worksheet
    Dim srcWs As Worksheet
    Dim dstPath As String
    Dim targetRow As Long
    Dim hasEmpty As Boolean
    
    ' 绑定源工作表
    Set srcWs = ThisWorkbook.Sheets("FORM.HDR 1.1")
    dstPath = "S:\Radiotherapy-Department\Brachytherapy\Spreadsheets\Developement\Josmi_Project _ DB\Postsource exchangeResults.xlsx"
    hasEmpty = False
    
    ' 统一做空值校验，提前弹出提示
    If srcWs.Range("M11") = "" Then
        MsgBox "Confirm 'Pre & 1st Post'source exchange RAKR measurement completed"
        hasEmpty = True
    End If
    If srcWs.Range("N11") = "" Then
        MsgBox "Confirm 'Pre & 1st Post'source exchange RAKR measurement completed"
        hasEmpty = True
    End If
    If srcWs.Range("O11") = "" Then
        MsgBox "Confirm 'Pre & Post'source exchange RAKR measurement completed"
        hasEmpty = True
    End If
    If srcWs.Range("P11") = "" Then
        MsgBox "Confirm 'Pre & Post'source exchange RAKR measurement completed"
        hasEmpty = True
    End If
    
    ' 存在空值直接终止流程
    If hasEmpty Then Exit Sub
    
    ' 单次打开目标工作簿，避免重复IO操作
    Set dstWb = Workbooks.Open(dstPath)
    Set dstWs = dstWb.Sheets("Result-1")
    
    ' 解锁目标工作表
    dstWs.Unprotect
    
    ' 整批次统一锚定目标写入行：以A列最后非空行+1作为本次新记录的固定行号
    ' 若业务需要补填已有未完成的记录，可替换此处逻辑为通过唯一标识（如测量日期、源编号）匹配已有行号
    targetRow = dstWs.Cells(dstWs.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 4组数据全部写入同一targetRow对应列，不再单独定位行
    srcWs.Range("M11:M12").Copy
    dstWs.Cells(targetRow, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    srcWs.Range("N11:N12").Copy
    dstWs.Cells(targetRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    srcWs.Range("O11:O12").Copy
    dstWs.Cells(targetRow, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    srcWs.Range("P11:P12").Copy
    dstWs.Cells(targetRow, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    ' 清空剪贴板
    Application.CutCopyMode = False
    
    ' 保护目标工作表、保存关闭
    dstWs.Protect
    dstWb.Save
    dstWb.Close
    
    ' 回到源表清空数据区域，弹出成功提示
    srcWs.Activate
    srcWs.Unprotect
    srcWs.Range("M11:P12").ClearContents
    MsgBox "SOURCE STRENGTH VERIFICATION RESULTS SAVED SUCCESSFULLY"
    srcWs.Protect
End Sub

改动说明 #

• 核心修复：取消原来每列单独找写入行的逻辑，整批次数据统一使用同一个固定行号写入，从根源避免行错位问题
• 冗余逻辑优化：将原来4次重复打开/关闭工作簿、重复解锁/保护工作表的操作合并为单次执行，减少共享文件访问冲突概率，运行效率更高
• 所有原有业务规则完全保留：空值提示、数值转置粘贴、工作表保护逻辑、源区域清空、成功提示均和原逻辑一致
• 适配扩展：如果存在跨天补填同批次未完成数据的场景，只需要修改targetRow的定位规则，通过批次唯一标识匹配到已有未完成的行号即可，不需要调整其他写入逻辑

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