VBA实战技巧26：使用递归确定所有的引用单元格

Sub test()
    Dim rngToCheck As Range
    Dim rngPrecedents As Range
    Dim rngPrecedent As Range
   
    Set rngToCheck = Range("A1")
   
    On Error Resume Next
    Set rngPrecedents = rngToCheck.Precedents
    On Error GoTo 0
   
    If rngPrecedents Is Nothing Then
       Debug.Print rngToCheck.Address(External:=True) & "没有引用单元格."
    Else
        For Each rngPrecedent In rngPrecedents
           Debug.Print rngPrecedent.Address(External:=True)
        Next rngPrecedent
    End If
End Sub

Sub test2()
    Dim rngToCheck As Range
    Dim dicAllPrecedents As Object
    Dim i As Long
   
    Set rngToCheck = Sheet1.Range("A1")
    Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
   
   Debug.Print "= = ="
   
    If dicAllPrecedents.Count = 0 Then
       Debug.Print rngToCheck.Address(External:=True); "没有引用单元格."
    Else
        For i= LBound(dicAllPrecedents.keys) To UBound(dicAllPrecedents.keys)
           Debug.Print "[ 层级:"; dicAllPrecedents.items()(i); " ]";
           Debug.Print "[ 地址:"; dicAllPrecedents.keys()(i); " ]";
           Debug.Print vbCrLf
        Nexti
    End If
   Debug.Print "= = ="
End Sub
 
'不能遍历关闭的工作簿中的引用单元格
'不能遍历受保护工作表中的引用单元格
'不能识别隐藏工作表中的引用单元格
Public Function GetAllPrecedents(ByRef rngToCheckAs Range) As Object
    Const lngTOP_LEVEL As Long = 1
    Dim dicAllPrecedents As Object
    Dim strKey As String
   
    Set dicAllPrecedents = CreateObject("Scripting.Dictionary")
   
   Application.ScreenUpdating = False
   
   GetPrecedents rngToCheck, dicAllPrecedents, lngTOP_LEVEL
    Set GetAllPrecedents = dicAllPrecedents
   
   Application.ScreenUpdating = True
End Function
 
Private Sub GetPrecedents(ByRef rngToCheck As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
    Dim rngCell As Range
    Dim rngFormulas As Range
   
    If Not rngToCheck.Worksheet.ProtectContents Then
        If rngToCheck.Cells.CountLarge > 1 Then
           On Error Resume Next
           Set rngFormulas = rngToCheck.SpecialCells(xlCellTypeFormulas)
           On Error GoTo 0
        Else
           If rngToCheck.HasFormula Then Set rngFormulas = rngToCheck
        End If
       
        If Not rngFormulas Is Nothing Then
           For Each rngCell In rngFormulas.Cells
               GetCellPrecedents rngCell, dicAllPrecedents, lngLevel
           Next rngCell
           rngFormulas.Worksheet.ClearArrows
        End If
    End If
End Sub
 
Private Sub GetCellPrecedents(ByRef rngCell As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
    Dim lngArrow As Long
    Dim lngLink As Long
    Dim blnNewArrow As Boolean
    Dim strPrecedentAddress As String
    Dim rngPrecedentRange As Range
   
    Do
       lngArrow = lngArrow + 1
       blnNewArrow = True
       lngLink = 0
       
        Do
           lngLink = lngLink + 1
           rngCell.ShowPrecedents
           On Error Resume Next
           Set rngPrecedentRange = rngCell.NavigateArrow(True, lngArrow, lngLink)
           If Err.Number <> 0 Then
               Exit Do
           End If
           On Error GoTo 0
            strPrecedentAddress =rngPrecedentRange.Address(False, False, xlA1, True)
           If strPrecedentAddress = rngCell.Address(False, False, xlA1, True) Then
               Exit Do
           Else
               blnNewArrow = False
               If Not dicAllPrecedents.exists(strPrecedentAddress) Then
                   dicAllPrecedents.Add strPrecedentAddress, lngLevel
                   GetPrecedents rngPrecedentRange, dicAllPrecedents, lngLevel + 1
               End If
           End If
        Loop
        If blnNewArrow Then Exit Do
    Loop
End Sub