如何列出excel公式中引用的所有單元格

如何列出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過程一遍一遍地相互調用，直到遍歷完所有引用單元格。

對于上面的示例工作表，運行代碼后的結果如下所示。

版權聲明：本文內容由網絡用戶投稿，版權歸原作者所有，本站不擁有其著作權，亦不承擔相應法律責任。如果您發現本站中有涉嫌抄襲或描述失實的內容，請聯系我們jiasou666@gmail.com 處理，核實后本網站將在24小時內刪除侵權內容。

版權聲明：本文內容由網絡用戶投稿，版權歸原作者所有，本站不擁有其著作權，亦不承擔相應法律責任。如果您發現本站中有涉嫌抄襲或描述失實的內容，請聯系我們jiasou666@gmail.com 處理，核實后本網站將在24小時內刪除侵權內容。