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而导致错误，该错误无法从工作表到工作表正确追溯引用。我把它修改了代码。

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

1 个答案: