忽略合并单元格的单元格去重计数——性能优化问题

• 场景：所有黄色单元格均包含公式，需统计这类含公式的单元格数量，但合并区域按独立合并单元计数（例如I4:J8区域为两个跨5行的合并单元格，仅计为2个）。
• 核心需求：对指定Range中符合条件的单元格去重计数（每个合并单元仅算1次），要求避免逐个遍历单元格，适配百万级单元格的处理场景。

现有实现代码（存在缺陷） #

以下代码尝试实现统计，但第一种方法逻辑错误，第二种逐个遍历的方法虽正确但效率极低，无法应对大数量级场景：

Public Sub Example()
    Dim ar As Range
    Dim count As Long
    Dim RealCount As Long
    Dim ra As Range, ws As Worksheet
    Set ws = ActiveSheet
    Set ra = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
    Debug.Print ra.Address
    For Each ar In ra.Areas
        If ar.Cells(1, 1).MergeArea.Address = ar.Address Then
            count = count + 1
        Else
            count = count + ar.Cells.count
        End If
    Next
    RealCount = GetCountRealSlowButCorrect(ra)
    Debug.Print "count by me but bad: "; count; " cells count: "; ra.Cells.count; " RealCount: "; RealCount
End Sub

Private Function GetCountRealSlowButCorrect(ra As Range) As Long
    Dim g As Range
    Dim su As Long
    su = ra.Cells.count
    For Each g In ra
        If g = g.MergeArea.Cells(1, 1) Then
            su = su - (g.MergeArea.Cells.count - 1)
        End If
    Next
    GetCountRealSlowButCorrect = su
End Function

高效实现思路与代码示例 #

针对百万级单元格的处理需求，推荐通过批量解析合并区域边界或字典去重的方式，减少Excel对象的频繁交互：

思路1：字典存储合并区域地址去重 #

利用字典记录唯一合并区域的地址，避免重复统计，同时通过批量处理Area减少单元格遍历：

Public Function EfficientMergeFormulaCount(ra As Range) As Long
    Dim mergeDict As Object
    Set mergeDict = CreateObject("Scripting.Dictionary")
    
    Dim ar As Range
    Dim mergeArea As Range
    Dim tempRng As Range
    
    For Each ar In ra.Areas
        If ar.MergeCells Then
            ' 整个Area为合并区域，直接记录其MergeArea地址
            Set mergeArea = ar.MergeArea
            mergeDict(mergeArea.Address) = vbNullString
        Else
            ' 批量处理非合并Area内的合并区域，避免逐个遍历单元格
            Set tempRng = ar
            Do While tempRng.Cells.Count > 0
                Set mergeArea = tempRng.Cells(1, 1).MergeArea
                ' 仅保留与目标区域交集的合并部分
                Set mergeArea = Intersect(mergeArea, ar)
                If Not mergeArea Is Nothing Then
                    mergeDict(mergeArea.MergeArea.Address) = vbNullString
                End If
                ' 移除已处理的合并区域，缩小待处理范围
                Set tempRng = Intersect(tempRng, tempRng.Offset(mergeArea.Rows.Count, 0))
                If tempRng Is Nothing Then
                    Set tempRng = Intersect(ar, ar.Columns(mergeArea.Columns.Count + 1).Resize(ar.Rows.Count))
                End If
            Loop
        End If
    Next ar
    
    EfficientMergeFormulaCount = mergeDict.Count
End Function

思路2：Union合并唯一合并单元左上角 #

通过Union操作收集所有合并单元的左上角单元格，最后统计该合并区域的单元格数量：

Public Function UniqueMergeTopLeftCount(ra As Range) As Long
    Dim uniqueRng As Range
    Dim ar As Range
    Dim mergeArea As Range
    
    For Each ar In ra.Areas
        If ar.MergeCells Then
            ' 合并区域直接取左上角
            If uniqueRng Is Nothing Then
                Set uniqueRng = ar.Cells(1, 1)
            ElseIf Not uniqueRng.Contains(ar.Cells(1, 1)) Then
                Set uniqueRng = Union(uniqueRng, ar.Cells(1, 1))
            End If
        Else
            ' 批量提取非合并Area内的合并单元左上角
            Set mergeArea = ar.Cells(1, 1).MergeArea
            Do While Not mergeArea Is Nothing
                If ra.Contains(mergeArea.Cells(1, 1)) Then
                    If uniqueRng Is Nothing Then
                        Set uniqueRng = mergeArea.Cells(1, 1)
                    ElseIf Not uniqueRng.Contains(mergeArea.Cells(1, 1)) Then
                        Set uniqueRng = Union(uniqueRng, mergeArea.Cells(1, 1))
                    End If
                End If
                ' 定位下一个未处理的单元格
                Set mergeArea = Intersect(ar, ar.Cells(mergeArea.Row + mergeArea.Rows.Count, mergeArea.Column))
            Loop
        End If
    Next ar
    
    UniqueMergeTopLeftCount = IIf(Not uniqueRng Is Nothing, uniqueRng.Cells.Count, 0)
End Function

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