Excel合并单元格自动筛选实现及VBA自定义函数递归异常问题求助

首先得明确递归触发的核心原因：当你在WorkingSub里给合并区域的其他单元格赋值时，Excel会触发工作表重新计算，而你的Exposure是自定义函数，这会导致函数再次被调用，进而又执行WorkingSub，形成无限递归，最终跳过了后续的格式粘贴和重新合并步骤。

下面给出两种可行的解决思路，你可以根据实际需求选择：

方案一：给自定义函数添加递归锁 #

在Exposure函数里加入静态变量作为递归标志，防止函数在执行子过程时被重复调用。修改后的代码如下：

Function Exposure(arg1 As Range, arg2 As Range) As Variant
    Static isRecursing As Boolean ' 静态变量，记录是否正在递归执行
    Dim result As Variant
    
    ' 如果正在递归，直接返回当前值，避免重复执行
    If isRecursing Then
        Exposure = Application.ThisCell.Value
        Exit Function
    End If
    
    Application.EnableEvents = False
    Application.Calculation = xlManual
    isRecursing = True ' 设置递归标志为True
    
    On Error GoTo Cleanup ' 确保即使出错也能重置标志
    
    ' 原有的计算逻辑
    If Application.ThisCell.Offset(, -1).Value <> "-" And Application.ThisCell.Offset(, -2).Value <> "-" Then
        result = Left(Application.ThisCell.Offset(, -1).Value, 1) * Left(Application.ThisCell.Offset(, -2).Value, 1)
    End If
    If result = 0 Then
        result = "-"
    End If
    
    ' 调用子过程处理合并单元格
    WorkingSub Application.ThisCell.MergeArea
    
    Exposure = result

Cleanup:
    isRecursing = False ' 重置递归标志
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
End Function

同时完善WorkingSub，确保最后重新合并单元格（原代码缺少这一步）：

Sub WorkingSub(rng As Range)
    Dim originalMergeArea As Range
    Set originalMergeArea = rng.MergeArea
    
    originalMergeArea.UnMerge
    ' 填充值到所有单元格
    originalMergeArea.Value = originalMergeArea.Cells(1).Value
    ' 重新合并区域
    originalMergeArea.Merge
    ' 复制下方格式（如果需要继承下方单元格格式）
    originalMergeArea.Offset(originalMergeArea.Cells.Count).Copy
    originalMergeArea.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False ' 清除复制状态
End Sub

这个方案的核心是用静态变量isRecursing锁住函数，当子过程执行赋值操作触发计算时，函数会直接返回当前值，不会重复执行逻辑，从而避免递归。

方案二：改用工作表Calculate事件处理合并单元格 #

另一种更稳健的思路是不在自定义函数里调用子过程，而是把合并单元格的处理逻辑放到工作表的Calculate事件中。这样可以彻底避免函数内的递归问题，因为计算完成后才会触发事件。

步骤如下：

1. 打开对应工作表的代码窗口（右键工作表标签→查看代码）
2. 粘贴以下代码：

Private Sub Worksheet_Calculate()
    Dim mergedRng As Range
    Dim cell As Range
    
    Application.EnableEvents = False
    Application.Calculation = xlManual
    
    ' 遍历所有包含Exposure函数的合并单元格
    For Each cell In Me.UsedRange
        If cell.MergeCells And cell.HasFormula Then
            If InStr(cell.Formula, "=Exposure(") > 0 Then
                Set mergedRng = cell.MergeArea
                mergedRng.UnMerge
                mergedRng.Value = cell.Value ' 填充计算值到所有单元格
                mergedRng.Merge ' 重新合并
                ' 复制下方格式（如果需要）
                mergedRng.Offset(mergedRng.Count).Copy
                mergedRng.PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
            End If
        End If
    Next cell
    
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
End Sub

然后修改Exposure函数，去掉调用WorkingSub的代码，只保留计算逻辑：

Function Exposure(arg1 As Range, arg2 As Range) As Variant
    Application.EnableEvents = False
    Application.Calculation = xlManual
    Dim result As Variant
    
    If Application.ThisCell.Offset(, -1).Value <> "-" And Application.ThisCell.Offset(, -2).Value <> "-" Then
        result = Left(Application.ThisCell.Offset(, -1).Value, 1) * Left(Application.ThisCell.Offset(, -2).Value, 1)
    End If
    If result = 0 Then
        result = "-"
    End If
    
    Exposure = result
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
End Function

这个方案的优势是分离了计算逻辑和合并单元格的处理逻辑，避免了函数内操作单元格导致的递归，同时代码结构更清晰，也更容易维护。

额外提示 #

如果你只需要让自动筛选识别合并区域的所有行，其实不需要真的合并单元格——可以取消合并，然后用条件格式模拟合并单元格的视觉效果（比如设置单元格边框、居中对齐），这样所有单元格都有值，自动筛选就能正常工作，还能避免合并单元格带来的各种VBA问题，这可能是最省心的方案。

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