如何列出excel公式中援用的所有单元格-英雄云拓展知识分享

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进程一遍一遍地相互调用，直到遍历完所有援用单元格。

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