VBA函数无法正确获取单元格全部Precedents与Dependents的问题求助

问题根源 #

你的代码存在两个核心问题：

1. .Precedents.Count 和 .Dependents.Count 不可靠——这两个属性返回的是去重后的所有引用单元格集合，若引用路径重复或跨工作簿/工作表，计数会失真；更关键的是，当单元格存在直接引用时，它们可能错误返回单元格自身。
2. 循环逻辑依赖错误的终止条件：你用不准确的Count属性控制循环，且NavigateArrow的参数调用没有覆盖所有引用路径，导致仅能拿到第一个甚至自身的引用。

修正后的代码 #

以下代码通过循环调用NavigateArrow直到触发错误（表示无更多引用箭头），准确捕获所有前置和从属单元格：

Function findEnds(rng As Range) As String
    Dim i As Integer
    Dim str As String
    Dim crng As Range ' 补充声明缺失变量
    Application.ScreenUpdating = False
    On Error Resume Next ' 临时启用错误捕获，检测是否存在更多箭头

    ' 收集前置引用单元格（Precedents）
    str = "PRECEDENTS:::"
    rng.ShowPrecedents
    i = 1
    Do
        Set crng = rng.NavigateArrow(True, i, 1)
        If Err.Number = 0 Then ' 无错误说明找到有效引用单元格
            str = str & vbCrLf & vbTab & crng.Address(External:=True)
            i = i + 1
        Else
            Err.Clear ' 清除错误，退出当前循环
            Exit Do
        End If
    Loop
    rng.Parent.ClearArrows

    ' 收集从属引用单元格（Dependents）
    str = str & vbCrLf & vbCrLf & "DEPENDENTS:::"
    rng.ShowDependents
    i = 1
    Do
        Set crng = rng.NavigateArrow(False, i, 1)
        If Err.Number = 0 Then
            str = str & vbCrLf & vbTab & crng.Address(External:=True)
            i = i + 1
        Else
            Err.Clear
            Exit Do
        End If
    Loop
    rng.Parent.ClearArrows

    Application.ScreenUpdating = True
    findEnds = str
End Function

关键改进点 #

• 弃用Count属性：改用错误捕获判断是否存在更多引用箭头，这是最可靠的方式——NavigateArrow在无对应箭头时会抛出错误。
• 补充变量声明：添加Dim crng As Range，避免隐式变量引发的潜在问题。
• 优化循环逻辑：从i=1开始循环，成功找到单元格则递增i，直到出错退出循环。
• 恢复屏幕更新：函数结束前重新启用Application.ScreenUpdating = True，避免Excel界面卡顿。

扩展说明 #

若需要递归查找所有间接引用（比如A引用B、B引用C，需定位到C），可在代码中加入递归逻辑，对每个找到的crng再次调用findEnds函数，但需注意处理循环引用避免死循环。

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