Excel VBA：如何将新单元格合并至已合并单元格

原宏无法处理上方为合并单元格的场景，核心原因有两点：

1. 当上方是合并区域时，Offset(-1,0)指向的是合并区域内的非首单元格，这类单元格的Value2为空，导致值对比不成立
2. 合并操作仅针对当前行与上一行，未扩展到已有的合并区域，无法实现连续匹配行的批量合并

' Check if "DATA","OPERATORE" and "VISIONATO DA" values are equals to the ones above them,
' if yes then merge cells

Application.DisplayAlerts = False ' 关闭合并弹窗提示
Dim ws As Worksheet
Set ws = Worksheets("Foglio2")

Dim log As Range
' 确定新插入行的基准单元格
If ws.Range("B2") = "" Then
    Set log = ws.Range("B2")
Else
    Set log = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0)
End If

Dim rng1 As Range   ' "DATA"列单元格
Dim rng2 As Range   ' "OPERATORE"列单元格
Dim rng3 As Range   ' "VISIONATO DA"列单元格
Set rng1 = log.Offset(0, -1)
Set rng2 = log.Offset(0, 7)
Set rng3 = log.Offset(0, 8)

' 获取上方对应列的有效对比单元格（兼容合并区域）
Dim compareRng1 As Range, compareRng2 As Range, compareRng3 As Range
Set compareRng1 = GetTopCell(rng1.Offset(-1, 0))
Set compareRng2 = GetTopCell(rng2.Offset(-1, 0))
Set compareRng3 = GetTopCell(rng3.Offset(-1, 0))

' 三个列值均匹配时执行合并
If Not compareRng1 Is Nothing And rng1.Value2 = compareRng1.Value2 And rng1.Value2 <> "" Then
    If Not compareRng2 Is Nothing And rng2.Value2 = compareRng2.Value2 And rng2.Value2 <> "" Then
        If Not compareRng3 Is Nothing And rng3.Value2 = compareRng3.Value2 And rng3.Value2 <> "" Then
            
            ' 合并当前单元格与上方整个合并区域
            Union(rng1, compareRng1.MergeArea).Merge
            Union(rng1, compareRng1.MergeArea).HorizontalAlignment = xlCenter
            Union(rng1, compareRng1.MergeArea).VerticalAlignment = xlCenter
            
            Union(rng2, compareRng2.MergeArea).Merge
            Union(rng2, compareRng2.MergeArea).HorizontalAlignment = xlCenter
            Union(rng2, compareRng2.MergeArea).VerticalAlignment = xlCenter
            
            Union(rng3, compareRng3.MergeArea).Merge
            Union(rng3, compareRng3.MergeArea).HorizontalAlignment = xlCenter
            Union(rng3, compareRng3.MergeArea).VerticalAlignment = xlCenter
        End If
    End If
End If

Application.DisplayAlerts = True

' 辅助函数：获取合并区域的顶部单元格（存储有效值的单元格）
Function GetTopCell(rng As Range) As Range
    If rng.MergeCells Then
        Set GetTopCell = rng.MergeArea.Cells(1, 1)
    Else
        Set GetTopCell = rng
    End If
    ' 边界处理：第一行无上方单元格，返回Nothing
    If GetTopCell.Row = 1 Then Set GetTopCell = Nothing
End Function

• 新增GetTopCell辅助函数，无论上方是普通单元格还是合并区域，都能精准获取存储有效值的顶部单元格
• 合并操作使用Union将当前单元格与上方整个合并区域合并，确保所有连续匹配的行都被纳入同一合并区域
• 增加边界判断，避免第一行时出现错误

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