Q：Excel没有提供便捷的方法来找到所给单元格的所有引用单元格，虽然Range对象有一个Precedents属性，但只适用于引用单元格都在同一工作表上的情况。
Q：Excel没有提供便捷的方法来找到所给单元格的所有引用单元格，虽然Range对象有一个Precedents属性，但只适用于引用单元格都在同一工作表上的情况。
例如，下所示的工作表Sheet1，在单元格A1中的公式为=B3+5，而单元格B3中的公式又引用了单元格D2和E2，单元格D2甚至引用了另一工作表Sheet2中的单元格A1。
通过公式选项卡中的“追踪引用单元格”命令，可以看到单元格A1的引用关系如下所示。
下面的程序：
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
If rngPrecedents Is Nothing Then
Debug.PrintrngToCheck.Address(External:=True) & “没有引用单元格.”
Else
For Each rngPrecedent In rngPrecedents
Debug.PrintrngPrecedent.Address(External:=True)
Next rngPrecedent
End If
End Sub
得到的结果是：
[Q&A49.xlsm]Sheet1′!$B$3
[Q&A49.xlsm]Sheet1′!$D$2
[Q&A49.xlsm]Sheet1′!$E$2
并没有追踪列出第3级的引用关系，即对工作表Sheet2中单元格A1的引用。
由于大多数电子表格计算横跨多个工作表，因此Precedents属性不能满足要求，能不能编写一个程序用来列出含有公式的单元格引用的所有单元格？
A：可以编写VBA程序来解决Precedents属性的局限。这个程序会确定所提供的单元格区域的引用单元格并以正确的引用顺序列出它们，唯一的限制是无法重新计算已关闭工作簿、隐藏的工作表、受保护工作表或循环引用中的引用单元格。
在colinlegg.wordpress.com中，使用下面的程序（本文在整理时略有修改）可以列出单元格A1的引用单元格和层级关系。
Sub testGetAllPrecedents()
Dim rngToCheck As Range
Dim dicAllPrecedents As Object
Dim i As Long
Dim str As String
Set rngToCheck =Sheet1.Range(“A1”)
Set dicAllPrecedents =GetAllPrecedents(rngToCheck)
str = “单元格” & ActiveCell.Address(False, False) & “中的公式为: ” _
& ActiveCell.Formula &vbCrLf
str = str & “其依次引用的单元格信息如下:” & vbCrLf & vbCrLf
str = str & “层级” & vbTab & “引用的单元格” & vbTab & vbTab & “公式” & vbCrLf
If dicAllPrecedents.Count = Then
MsgBox rngToCheck.Address(External:=True)& “没有引用单元格.”
Else
For i = LBound(dicAllPrecedents.Keys)To UBound(dicAllPrecedents.Keys)
str = str &dicAllPrecedents.Items()(i) & vbTab
str = str &dicAllPrecedents.Keys()(i) & vbTab
str = str & Range(dicAllPrecedents.Keys()(i)).Formula& vbCrLf
Next i
End If
MsgBox str
End Sub
Public Function GetAllPrecedents(ByRef rngToCheck As 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.ProtectContentsThen
If rngToCheck.Cells.CountLarge > 1Then
On Error Resume Next
Set rngFormulas =rngToCheck.SpecialCells(xlCellTypeFormulas)
On Error GoTo
Else
If rngToCheck.HasFormula Then SetrngFormulas = rngToCheck
End If
If Not rngFormulas Is Nothing Then
For Each rngCell InrngFormulas.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 =
Do
lngLink = lngLink + 1
rngCell.ShowPrecedents
On Error Resume Next
Set rngPrecedentRange =rngCell.NavigateArrow(True, lngArrow, lngLink)
If Err.Number <> Then
Exit Do
End If
On Error GoTo
strPrecedentAddress =rngPrecedentRange.Address(False, False, xlA1, True)
If strPrecedentAddress =rngCell.Address(False, False, xlA1, True) Then
Exit Do
Else
blnNewArrow = False
If NotdicAllPrecedents.Exists(strPrecedentAddress) Then
dicAllPrecedents.Add strPrecedentAddress,lngLevel
GetPrecedentsrngPrecedentRange, dicAllPrecedents, lngLevel + 1
End If
End If
Loop
If blnNewArrow Then Exit Do
Loop
End Sub
GetAllPrecedents函数返回一个Dictionary对象，包含在键中的单元格地址和在项中的引用层级。代码使用了递归：GetPrecedents过程和GetCellPrecedents过程一遍一遍地相互调用，直到遍历完所有引用单元格。
对于上面的示例工作表，运行代码后的结果如下所示。
