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属性的局限。这个程序会确定所提供的单元格区域的引用单元格并以正确的引用顺序列出它们，唯一的限制是无法重新计算已关闭工作簿、隐藏的工作表、受保护工作表或循环引用中的引用单元格。

使用下面的程序（本文在整理时略有修改）可以列出单元格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过程一遍一遍地相互调用，直到遍历完所有引用单元格。

对于上面的示例工作表，运行代码后的结果如下所示。

阅读全文