Excel VBA中NavigateArrow无法遍历所有从属单元格问题求助

在Excel VBA中，尝试用NavigateArrow方法遍历依赖某一单元格的所有公式单元格。工作表设置如下：

• Sheet1的A1为数值，B1和E1公式为=A1
• Sheet2的A2和E2公式为=Sheet1!A1
• Sheet3的A3和E3公式为=Sheet1!A1

手动通过「公式>公式审核>追踪从属单元格」能正常显示所有6个从属单元格，但运行以下代码后，仅能遍历到3个单元格：

Sub TraceAllDependents2()
    Const NAVIGATE_DEPENDENTS As Boolean = False
    Dim rgTraceDep As Range, rgDepRange As Range
    Dim rgBeforeNav As Range, rgAfterNav As Range
    Dim iArrowCounter As Long
    
    '===========================================================================
    'SET THE CELL TO TRACE HERE:
    Set rgTraceDep = ThisWorkbook.Worksheets("Sheet1").Range("A1")
    '===========================================================================
    
    iArrowCounter = 0 'init. Arrows are 1-based.
    Set rgBeforeNav = rgTraceDep
    rgTraceDep.ShowDependents
    
    Do 'loop through arrows:
        iArrowCounter = iArrowCounter + 1
        rgTraceDep.NavigateArrow NAVIGATE_DEPENDENTS, iArrowCounter: DoEvents
        Set rgAfterNav = ActiveCell
        If rgBeforeNav.Address(External:=True) <> rgAfterNav.Address(External:=True) Then
            'we followed an arrow:
            Debug.Print CellAddressWithSheetname(rgAfterNav.Address(External:=True)), "Arrow #" & iArrowCounter
        Else
            'this cell does NOT have any more arrows.
            Exit Do
        End If
    Loop 'until done with arrows.

    
    rgTraceDep.Parent.ClearArrows
End Sub

Function CellAddressWithSheetname(external_address As String) As String
    Dim strAddrSht As String
    strAddrSht = Replace(external_address, ThisWorkbook.Name, "")
    strAddrSht = Replace(strAddrSht, "[]", "")
    CellAddressWithSheetname = strAddrSht
End Function

运行后立即窗口输出：

Sheet2!$A$2            Arrow #1
Sheet1!$E$1            Arrow #2
Sheet1!$B$1            Arrow #3

问题原因 #

你依赖NavigateArrow的索引遍历，但该方法的第二个参数对应的是箭头分支，而非单个从属单元格。当多个从属单元格位于同一工作表或不同工作表时，它们可能共享同一个箭头分支索引，导致循环在遍历完3个分支后就因返回原单元格而退出，漏掉了Sheet2的E2、Sheet3的A3和E3这些从属单元格。

解决方法 #

改用Range.Dependents属性，它会直接返回所有直接依赖目标单元格的单元格集合（包括跨工作表的），无需依赖箭头导航。

遍历直接从属单元格的代码

Sub TraceAllDependents()
    Dim rgTraceDep As Range
    Dim depCell As Range
    
    ' 设置要追踪的目标单元格
    Set rgTraceDep = ThisWorkbook.Worksheets("Sheet1").Range("A1")
    
    ' 检查是否存在从属单元格
    If Not rgTraceDep.Dependents Is Nothing Then
        ' 遍历所有直接从属单元格
        For Each depCell In rgTraceDep.Dependents
            Debug.Print depCell.Parent.Name & "!" & depCell.Address, "直接从属"
        Next depCell
    Else
        Debug.Print "未找到从属单元格"
    End If
End Sub

递归遍历所有直接+间接从属单元格的代码

如果需要追踪间接依赖的单元格（比如某单元格依赖B1，而B1依赖A1），可以通过递归实现：

Sub TraceAllDependentsRecursive()
    Dim rgTraceDep As Range
    
    Set rgTraceDep = ThisWorkbook.Worksheets("Sheet1").Range("A1")
    
    ' 启动递归追踪
    TraceDependents rgTraceDep
End Sub

Sub TraceDependents(rg As Range)
    Dim depCell As Range
    Dim tracedCells As New Collection
    
    On Error Resume Next
    For Each depCell In rg.Dependents
        ' 避免重复追踪同一单元格
        tracedCells.Add depCell, Key:=depCell.Address(External:=True)
        If Err.Number = 0 Then
            Debug.Print depCell.Parent.Name & "!" & depCell.Address, "从属单元格"
            ' 递归追踪当前单元格的从属
            TraceDependents depCell
        End If
        Err.Clear
    Next depCell
    On Error GoTo 0
End Sub

补充说明 #

• Range.Dependents仅返回直接从属单元格，间接从属需要递归遍历每个从属单元格的Dependents属性。
• 原代码中NAVIGATE_DEPENDENTS = False的设置是正确的（该参数为False表示追踪从属单元格，True表示追踪引用单元格），但NavigateArrow本身更适合单个箭头的导航操作，不适合批量遍历所有从属单元格。

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