如何合并VBA中重叠的Range区域以消除重复单元格？

先看问题中的代码：

Dim rng As Range
Dim rngCell As Range

Set rng = ActiveSheet.Cells(2, 2).Resize(3, 3)
Set rng = Union(rng, ActiveSheet.Cells(3, 3).Resize(3, 3))
Set rng = Union(rng, ActiveSheet.Cells(4, 4).Resize(3, 3))

'Shows 27, should be 19
MsgBox rng.Cells.Count

rng.ClearContents
For Each rngCell In rng.Cells
    rngCell = rngCell + 1
Next rngCell

用Union合并三个重叠区域后，rng.Cells.Count会把重叠单元格重复计数，导致总数显示27而非实际的19，遍历的时候也会重复处理同一单元格。下面提供几种实用的扁平化方法：

方法一：用字典记录唯一单元格地址 #

这是最通用的方案，不管单元格有没有值都能用：

Sub FlattenRange()
    Dim rng As Range
    Dim rngCell As Range
    Dim uniqueCells As Object
    Dim flattenedRng As Range
    
    '初始化原合并区域
    Set rng = ActiveSheet.Cells(2, 2).Resize(3, 3)
    Set rng = Union(rng, ActiveSheet.Cells(3, 3).Resize(3, 3))
    Set rng = Union(rng, ActiveSheet.Cells(4, 4).Resize(3, 3))
    
    '创建字典用于存储唯一单元格地址
    Set uniqueCells = CreateObject("Scripting.Dictionary")
    
    '遍历原区域，筛选出唯一单元格
    For Each rngCell In rng.Cells
        If Not uniqueCells.Exists(rngCell.Address) Then
            uniqueCells.Add rngCell.Address, rngCell
            '逐步构建扁平化后的区域
            If flattenedRng Is Nothing Then
                Set flattenedRng = rngCell
            Else
                Set flattenedRng = Union(flattenedRng, rngCell)
            End If
        End If
    Next rngCell
    
    '验证结果，此时会显示19
    MsgBox flattenedRng.Cells.Count
    
    '对扁平化后的区域执行操作，不会重复处理单元格
    flattenedRng.ClearContents
    For Each rngCell In flattenedRng.Cells
        rngCell = rngCell + 1
    Next rngCell
End Sub

方法二：用标记法结合SpecialCells #

适合临时场景，注意不要覆盖原有数据（可以先备份）：

Sub FlattenRangeWithMarker()
    Dim rng As Range
    Dim tempRng As Range
    Dim originalValues As Variant '用于备份原数据
    
    '初始化原合并区域
    Set rng = ActiveSheet.Cells(2, 2).Resize(3, 3)
    Set rng = Union(rng, ActiveSheet.Cells(3, 3).Resize(3, 3))
    Set rng = Union(rng, ActiveSheet.Cells(4, 4).Resize(3, 3))
    
    '备份原数据（可选，根据需求决定）
    originalValues = rng.Value
    
    '给所有单元格标记一个临时值（比如当前时间）
    rng.Value = Now()
    
    '提取所有带有标记的单元格，此时重叠单元格只会被识别一次
    Set tempRng = rng.SpecialCells(xlCellTypeConstants)
    
    '验证数量，显示19
    MsgBox tempRng.Cells.Count
    
    '恢复原数据（如果之前备份了）
    rng.Value = originalValues
    
    '对扁平化后的区域操作
    tempRng.ClearContents
    For Each rngCell In tempRng.Cells
        rngCell = rngCell + 1
    Next rngCell
End Sub

方法三：自定义复用函数 #

如果需要多次使用扁平化功能，可以封装成函数：

Function GetFlattenedRange(sourceRng As Range) As Range
    Dim cell As Range
    Dim dict As Object
    Dim resultRng As Range
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    '遍历源区域，筛选唯一单元格
    For Each cell In sourceRng.Cells
        If Not dict.Exists(cell.Address) Then
            dict.Add cell.Address, cell
            If resultRng Is Nothing Then
                Set resultRng = cell
            Else
                Set resultRng = Union(resultRng, cell)
            End If
        End If
    Next cell
    
    '返回扁平化后的区域
    Set GetFlattenedRange = resultRng
End Function

'调用示例
Sub TestFlatten()
    Dim originalRng As Range
    Dim flattenedRng As Range
    
    Set originalRng = ActiveSheet.Cells(2, 2).Resize(3, 3)
    Set originalRng = Union(originalRng, ActiveSheet.Cells(3, 3).Resize(3, 3))
    Set originalRng = Union(originalRng, ActiveSheet.Cells(4, 4).Resize(3, 3))
    
    '调用自定义函数获取扁平化区域
    Set flattenedRng = GetFlattenedRange(originalRng)
    
    MsgBox flattenedRng.Cells.Count '显示19
End Sub

注意事项 #

• 字典方法兼容性最好，适用于所有场景
• 标记法要注意数据备份，避免覆盖原有内容
• 自定义函数可以在多个VBA过程中重复调用，提升效率

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