追溯缺失的参考单元格（查找先例）

Question

简介

我有一个电子表格，其中包含由 VBA 宏读取的公式。有时，这些公式会链接到丢失引用的单元格。 （关系树可以上升到未定义的级别）

问题说明

我想要实现的是，每当发生这种情况时，代码都会向用户返回一个带有原始恶意单元位置的消息框。 （将错误追溯到原点）。

我面临的主要困难是按照正确的分支找到错误的根源。

示例

一个包含两个工作表的工作簿，公式如下：

• 单元格Sheet1!A1 = =IF(#REF!="", "", B2)（有人替换了原来的单元格内容，现在引用丢失了）
• 单元格Sheet1!B1 = =A1
• 单元格Sheet1!B2 = =11
• 单元格Sheet2!A1 = =12
• 单元格Sheet2!B1 = =A1+Sheet1!A1+Sheet1!B1

我有兴趣将 Sheet2!B1 追溯到其原始引用错误。

到目前为止尝试过的代码：

Sub CheckRangeB1()
    Dim RangeB1 As Range
    Dim RogueAddress As String
    Set RangeB1 = Sheets("Sheet2").Range("B1")

    RogueAddress = MissingRef(RangeB1)
    MsgBox RogueAddress
End Sub

Public Function MissingRef(ByVal CheckRange As Range) As String
    Dim RogueCell As Range
    If IsError(CheckRange) Then
        If CheckRange.Value = CVErr(xlErrRef) Then
            If HasPrecedents(CheckRange) = False Then
                MissingRef = CheckRange.Address
            ElseIf IsError(CheckRange.DirectPrecedents) Then
                MissingRef = MissingRef(CheckRange.DirectPrecedents)
            Else
                MissingRef = CheckRange.Address
            End If
        End If
    Else
        MissingRef = "NOERROR"
    End If
End Function

Public Function HasPrecedents(ByVal target As Range) As Boolean
    On Error Resume Next
    HasPrecedents = target.DirectPrecedents.Count
End Function

目前这没什么用，因为.DirectPrecedents 只是在追溯Sheet2!A1。

编辑

另一种方法可能是解析公式并遵循引用的单元格。但我不确定如何提取引用的单元格，而事先不知道公式的外观。我还是更喜欢.DirectPrecedents 方法。 谢谢。

Answer 1

最后我解决了它，虽然它比一开始看起来更难。

附加的代码会追溯缺少引用的原始单元格，但只是找到的第一个。 （即，如果有两个单元格缺少引用，它将只返回第一个）

它应该适用于任何缺少参考的情况。

在互联网上找到一些代码，主要遵循@siddharth-rout 指出的Recursive VBA Precedents 的这条线索，我得到了：

Option Explicit
Sub CheckRangeB1()
    Dim RangeB1 As Range, PrecedentsRange As Range
    Dim RogueAddress As String
    Set RangeB1 = Sheets("Sheet2").Range("B1")

    Dim PrecedentsString As Variant
    RogueAddress = MissingRef(RangeB1)
    MsgBox RogueAddress
End Sub

Public Function MissingRef(ByVal CheckRange As Range) As String
    Dim RogueCell As Range
    Dim PrecedString() As String
    Dim returnString As String
    Dim ErrorCheck As Boolean
    Dim i As Long, UpperBound As Long
    If IsError(CheckRange) Then
        If CheckRange.Value = CVErr(xlErrRef) Then
            UpperBound = UBound(FindPrecedents(CheckRange))
            ReDim PrecedString(UpperBound)
            PrecedString = FindPrecedents(CheckRange)
            If UpperBound = 0 And PrecedString(0) = "" Then
                MissingRef = "'" & CheckRange.Parent.Name & "'!" & CheckRange.Address
            Else
                ErrorCheck = False
                For i = 1 To UBound(PrecedString)
                    If IsError(Range(PrecedString(i))) Then
                        ErrorCheck = True
                        MissingRef = MissingRef(Range(PrecedString(i)))
                        Exit For
                    End If
                Next
                If ErrorCheck = False Then
                    MissingRef = "'" & CheckRange.Parent.Name & "'!" & CheckRange.Address
                End If

            End If
        End If
    Else
        MissingRef = "NOERROR"
    End If
End Function

Function FindPrecedents(ByVal Rng As Range) As Variant
    ' written by Bill Manville
    ' With edits from PaulS
    ' Further edited by LG
    ' this procedure finds the cells which are the direct precedents of the active cell
    Dim ReturnRng() As String
    Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
    Dim stMsg As String
    Dim bNewArrow As Boolean
    Application.ScreenUpdating = False
    Rng.ShowPrecedents
    Set rLast = Rng
    iArrowNum = 1
    iLinkNum = 1
    bNewArrow = True
    Do
        Do
            Application.Goto rLast
            On Error Resume Next
            ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
            If Err.Number > 0 Then Exit Do
            On Error GoTo 0
            If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
            bNewArrow = False
            If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
                If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
                    ' local
                    stMsg = stMsg & ";" & Selection.Address
                Else
                    stMsg = stMsg & ";" & "'" & Selection.Parent.Name & "'!" & Selection.Address
                End If
            Else
                ' external
                stMsg = stMsg & ";" & Selection.Address(external:=True)
            End If
            iLinkNum = iLinkNum + 1  ' try another link
        Loop
        If bNewArrow Then Exit Do
        iLinkNum = 1
        bNewArrow = True
        iArrowNum = iArrowNum + 1  'try another arrow
    Loop
    rLast.Parent.ClearArrows
    Application.Goto rLast

    If stMsg = "" Then
        ReDim ReturnRng(0)
        ReturnRng(0) = ""
    Else
        ReDim ReturnRng(0 To UBound(Split(stMsg, ";")))
        ReturnRng = Split(stMsg, ";")
    End If

    FindPrecedents = ReturnRng()

    'Exit Function
End Function

希望有人觉得它有用！

编辑

当我试图概括代码时，由于使用了.DirectPrecedents，我发现了一个错误，它不能正确地从工作表追溯到工作表的引用。我删除了它并修复了代码。