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

excelperfect

在Excel中，经常存在一个单元格引用另一个单元格中，而另一个单元格又引用其他单元格的情形。如何使用VBA代码编程确定指定单元格的所有引用单元格呢？

引用单元格是由公式引用并在 Excel 的计算树中识别的单元格。例如，如果在单元格A1中有公式=B2，那么单元格B2是单元格A1的引用单元格；如果在单元格B2中也有公式=C3，那么单元格B2（第一级）和单元格C3（第二级）都是单元格A1的引用单元格。

可以单击功能区“公式”选项卡“公式审核”组中的“追踪引用单元格”来追踪引用的单元格，如下图1所示。

图1

根据VBA帮助文件，Range.Precedents属性返回一个Range对象，代表所有引用的单元格。因此，编写下面的代码：

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 IfEnd Sub

针对图1所示的工作表，上面代码的输出结果如下图2所示。

图2

立即窗口中的输出告诉我们，Precedents属性适用于这个简单的示例，但是这个示例和帮助文件没有告诉我们的是它不会返回其他工作表或其他工作簿上的引用单元格。这个限制由Range.Precedents属性的定义所限制，因为该属性返回一个Range对象，而Range对象不能跨不同工作表引用单元格区域。

一种针对Range.Precedents属性不足的解决方案是使用Range.ShowPrecedents方法显示导航箭头，然后使用Range.NavigateArrow方法沿着每个箭头导航。

然而，还可以使用递归编程技术来解决。这也是展示递归技术的一个极好的示例。

代码如下：

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 = TrueEnd 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 IfEnd 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    LoopEnd Sub

GetAllPrecedents函数返回一个Dictionary对象，包含键中的单元格区域地址和项中的引用单元格层级。代码中最重要的概念是递归：GetPrecedents过程和GetCellPrecedents过程一遍又一遍地相互调用，直到它们遍历完引用单元格。对代码功能的一个简单增强是对它可以到达的层级数添加了限制：在递归技术中经常需要设置这样的限制。

注意，这段代码不会遍历关闭的工作簿或受保护的工作表追踪引用单元格，也不会在隐藏的工作表中找到引用单元格。

GetAllPrecedents函数可能会返回重叠的地址，例如B2:B10和B4，因为它使用联合单元格区域地址以提高效率。当代码沿引用单元格树导航时，如果它遇到之前导航过的单元格，将忽略它。同样，这是出于效率的目的。该函数不能作为自定义函数工作，因为当调用者是Range时，Range.ShowPrecedents和Range.NavigateArrows方法被禁用。

在代码中使用了Range.CountLarge，如果使用的是Excel2003或更早版本，则需要将其更改为Range.Count。

在Excel2010之前的版本中，Range.SpecialCells的返回值限制为8,192个不连续的单元格。你不可能打破此限制。

注：本文学习整理自colinlegg.wordpress.com，供有兴趣的朋友参考。

欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。

欢迎到知识星球：完美Excel社群，进行技术交流和提问，获取更多电子资料。