VBA实现合并单元格拆分后对应行单元格左移的技术求助

问题场景 #

现有一段VBA代码，用于从每周更新的库存工作表Counts中复制指定数值区域，转置粘贴至Plates per Week工作表的下一行做记录。但Counts表中选取的区域包含垂直合并单元格（F6:F28），粘贴后对应Plates per Week表的E3:AB3区域。直接使用Sheets("Plates per Week").Cells.UnMerge拆分所有单元格会导致表头错位，需要实现仅处理粘贴行的合并单元格，并将该行后续单元格左移1位的功能。

原复制粘贴代码 #

'selects and copies ranges containg total plate counts'
Dim range1 As Range, range2 As Range, multipleRange As Range
Set range1 = Sheets("Counts").Range("F3:F32")
Set range2 = Sheets("Counts").Range("F35:F39")
Set range3 = Sheets("Counts").Range("F42:F46")
Set multipleRange = Union(range1, range2, range3)

'copies entire range of counts'
multipleRange.Copy

'transposes and pastes counts into next blank row on plates per week sheet'
Sheets("Plates per Week").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True

原拆分单元格代码（会导致表头错位） #

'unmerges cells all cells in sheet'
Sheets("Plates per Week").Cells.UnMerge

解决方案代码 #

Sub UpdatePlateCounts()
    Dim range1 As Range, range2 As Range, range3 As Range, multipleRange As Range
    Dim targetSheet As Worksheet
    Dim targetRow As Long
    Dim mergedCell As Range
    Dim lastCol As Long
    
    ' 定义要复制的区域
    Set range1 = Sheets("Counts").Range("F3:F32")
    Set range2 = Sheets("Counts").Range("F35:F39")
    Set range3 = Sheets("Counts").Range("F42:F46")
    Set multipleRange = Union(range1, range2, range3)
    
    ' 复制并转置粘贴到目标表的下一行
    Set targetSheet = Sheets("Plates per Week")
    targetRow = targetSheet.Range("B" & targetSheet.Rows.Count).End(xlUp).Offset(1, 0).Row
    multipleRange.Copy
    targetSheet.Range("B" & targetRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    ' 仅处理当前粘贴行的合并单元格，避免影响表头
    With targetSheet.Rows(targetRow)
        ' 遍历该行的所有合并单元格区域
        For Each mergedCell In .MergeAreas
            mergedCell.UnMerge ' 拆分合并单元格
            ' 仅处理E列及之后的区域（对应原问题的E3:AB3范围）
            If mergedCell.Column >= 5 Then
                ' 获取该行最后一个有内容的列号
                lastCol = .Cells(.Cells.Count).End(xlToLeft).Column
                ' 将合并单元格右侧的内容左移一位，填补空白
                .Range(.Cells(mergedCell.Column + 1), .Cells(lastCol)).Cut
                .Cells(mergedCell.Column).Insert Shift:=xlToRight
            End If
        Next mergedCell
    End With
    
    ' 清除剪贴板状态，避免后续操作干扰
    Application.CutCopyMode = False
End Sub

代码核心逻辑 #

• 精准定位刚粘贴数据的目标行，只处理该行的合并单元格，完全不触碰表头区域，从根源避免表头错位
• 拆分合并单元格后，仅将该单元格右侧的内容左移一位，精准修正因合并单元格粘贴产生的空白
• 清除剪贴板状态，避免Excel保留复制操作的残留状态

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