Excel VBA代码可跟踪单元的先例 [英] Excel VBA code to trace precedents of cell

问题描述

我有以下代码，该代码跟踪活动单元的先例，并弹出带有信息的消息框. (它还会搜索其他工作表和工作簿中的先例.)

I have the following code which traces the precedents of an active cell and spits out a message box with the info. (It also searches for precedents in other worksheets and workbooks).

我是VBA的新手，我希望获得有关更改此代码的帮助，以便在活动工作表之后将先例单元格，公式和地址吐出到新的工作表中.请有人可以帮助我了解如何执行此操作.

I am new to VBA, and I would like to request help on changing this code to spit out the precedent cell, formula, and address into a new worksheet after the active worksheet. Please can someone help me understand how to do this.

我应该创建一个新函数来创建新工作表并将动态信息复制到第一个子项中吗?

Should I create a new function to create a new sheet and copy the dynamic info onto it within the first sub?

例如，如果我在Sheet1的单元格C1中具有公式A1 + B1，那么我想要在Sheet2(新创建的工作表)中一行，将目标单元格显示为C1，将目标表格显示为Sheet1，源单元格为A1，源表为Sheet1.我还希望Sheet2中的另一行将目标单元格显示为C1，将目标表显示为Sheet1，将源单元格显示为B1，将源表显示为Sheet1.

For example, if I have the formula A1 + B1 in cell C1 of Sheet1, then I want a row in Sheet2 (newly created sheet) which shows Target Cell as C1, Target Sheet as Sheet1, Source Cell as A1, and Source Sheet as Sheet1. I also want another row in Sheet2 which shows Target Cell as C1, Target Sheet as Sheet1, Source Cell as B1, and Source Sheet as Sheet1.

Sheet2:

代码:

Option Explicit 
Public OtherWbRefs As Collection 
Public ClosedWbRefs As Collection 
Public SameWbOtherSheetRefs As Collection 
Public SameWbSameSheetRefs As Collection 
Public CountOfClosedWb As Long 
Dim headerString As String 

Sub RunMe() 
    Call FindCellPrecedents(ActiveCell) 
End Sub 

Sub FindCellPrecedents(homeCell As Range) 
    Dim i As Long, j As Long, pointer As Long 
    Dim maxReferences As Long 
    Dim outStr As String 
    Dim userInput As Long 

    If homeCell.HasFormula Then 
        Set OtherWbRefs = New Collection: CountOfClosedWb = 0 
        Set SameWbOtherSheetRefs = New Collection 
        Set SameWbSameSheetRefs = New Collection 

        Rem find closed precedents from formula String 
        Call FindClosedWbReferences(homeCell) 

        Rem find Open precedents from navigate arrows 
        homeCell.Parent.ClearArrows 
        homeCell.ShowPrecedents 
        headerString = "in re: the formula in " & homeCell.Address(, , , True) 
        maxReferences = Int(Len(homeCell.Formula) / 3) + 1 
On Error GoTo LoopOut: 
        For j = 1 To maxReferences 
            homeCell.NavigateArrow True, 1, j 
            If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then 
                Rem closedRef 
                Call CategorizeReference("<ClosedBook>", homeCell) 
            Else 
                Call CategorizeReference(ActiveCell, homeCell) 
            End If 
        Next j 
LoopOut: 

        On Error GoTo 0 
        For j = 2 To maxReferences 
            homeCell.NavigateArrow True, j, 1 
            If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then Exit For 
            Call CategorizeReference(ActiveCell, homeCell) 
        Next j 
        homeCell.Parent.ClearArrows 

        Rem integrate ClosedWbRefs (from parsing) With OtherWbRefs (from navigation) 
        If ClosedWbRefs.Count <> CountOfClosedWb Then 
            If ClosedWbRefs.Count = 0 Then 
                MsgBox homeCell.Address(, , , True) & " contains a formula with no precedents." 
                Exit Sub 
            Else 
                MsgBox "string-" & ClosedWbRefs.Count & ":nav " & CountOfClosedWb 
                MsgBox "Methods find different # of closed precedents." 
                End 
            End If 
        End If 

        pointer = 1 
        For j = 1 To OtherWbRefs.Count 
            If OtherWbRefs(j) Like "<*" Then 
                OtherWbRefs.Add Item:=ClosedWbRefs(pointer), key:="closed" & CStr(pointer), after:=j 
                pointer = pointer + 1 
                OtherWbRefs.Remove j 
            End If 
        Next j 

        Rem present findings 
        outStr = homeCell.Address(, , , True) & " contains a formula with:" 
        outStr = outStr & vbCrLf & vbCrLf & CountOfClosedWb & " precedents in closed workbooks." 
        outStr = outStr & vbCr & (OtherWbRefs.Count - CountOfClosedWb) & " precedents in other workbooks that are open." 
        outStr = outStr & vbCr & SameWbOtherSheetRefs.Count & " precedents on other sheets in the same workbook." 
        outStr = outStr & vbCr & SameWbSameSheetRefs.Count & " precedents on the same sheet." 
        outStr = outStr & vbCrLf & vbCrLf & "YES - See details about Other Books." 
        outStr = outStr & vbCr & "NO - See details about The Active Book." 
        Do 
            userInput = MsgBox(prompt:=outStr, Title:=headerString, Buttons:=vbYesNoCancel + vbDefaultButton3) 
            Select Case userInput 
            Case Is = vbYes 
                MsgBox prompt:=OtherWbDetail(), Title:=headerString, Buttons:=vbOKOnly 
            Case Is = vbNo 
                MsgBox prompt:=SameWbDetail(), Title:=headerString, Buttons:=vbOKOnly 
            End Select 
        Loop Until userInput = vbCancel 
    Else 
        MsgBox homeCell.Address(, , , True) & vbCr & " does not contain a formula." 
    End If 
End Sub 

Sub CategorizeReference(Reference As Variant, Home As Range) 
    Rem assigns reference To the appropriate collection 
    If TypeName(Reference) = "String" Then 
        Rem String indicates reference To closed Wb 
        OtherWbRefs.Add Item:=Reference, key:=CStr(OtherWbRefs.Count) 
        CountOfClosedWb = CountOfClosedWb + 1 
    Else 
        If Home.Address(, , , True) = Reference.Address(, , , True) Then Exit Sub 
        If Home.Parent.Parent.Name = Reference.Parent.Parent.Name Then 
            Rem reference In same Wb 
            If Home.Parent.Name = Reference.Parent.Name Then 
                Rem sameWb sameSheet 
                SameWbSameSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbSameSheetRefs.Count) 
            Else 
                Rem sameWb Other sheet 
                SameWbOtherSheetRefs.Add Item:=Reference.Address(, , , True), key:=CStr(SameWbOtherSheetRefs.Count) 
            End If 
        Else 
            Rem reference To other Open Wb 
            OtherWbRefs.Add Item:=Reference.Address(, , , True), key:=CStr(OtherWbRefs.Count) 
        End If 
    End If 
End Sub 

Sub FindClosedWbReferences(inRange As Range) 
    Rem fills the collection With closed precedents parsed from the formula String 
    Dim testString As String, returnStr As String, remnantStr As String 
    testString = inRange.Formula 
    Set ClosedWbRefs = New Collection 

    Do 
        returnStr = NextClosedWbRefStr(testString, remnantStr) 
        ClosedWbRefs.Add Item:=returnStr, key:=CStr(ClosedWbRefs.Count) 
        testString = remnantStr 
    Loop Until returnStr = vbNullString 

    ClosedWbRefs.Remove ClosedWbRefs.Count 
End Sub 
Function NextClosedWbRefStr(FormulaString As String, Optional ByRef Remnant As String) As String 
    Dim workStr As String 
    Dim start As Long, interval As Long, del As Long 
    For start = 1 To Len(FormulaString) 
        For interval = 2 To Len(FormulaString) - start + 1 
            workStr = Mid(FormulaString, start, interval) 
            If workStr Like Chr(39) & "[!!]*'![$A-Z]*#" Then 
                If workStr Like Chr(39) & "[!!]*'!*[$1-9A-Z]#" Then 
                    interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "#") 
                    interval = interval - 3 * CLng(Mid(FormulaString, start + interval, 1) = ":") 
                    interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]") 
                    interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]") 
                    interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]") 
                    interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]") 
                    NextClosedWbRefStr = Mid(FormulaString, start, interval) 
                    Remnant = Mid(FormulaString, start + interval) 
                    Exit Function 
                End If 
            End If 
        Next interval 
    Next start 
End Function 

Function OtherWbDetail() As String 
    Rem display routine 
    OtherWbDetail = OtherWbDetail & "There are " & OtherWbRefs.Count & " references to other workbooks. " 
    OtherWbDetail = OtherWbDetail & IIf(CBool(CountOfClosedWb), CountOfClosedWb & " are closed.", vbNullString) 
    OtherWbDetail = OtherWbDetail & vbCr & "They appear in the formula in this order:" & vbCrLf & vbCrLf 
    OtherWbDetail = OtherWbDetail & rrayStr(OtherWbRefs, vbCr) 
End Function 
Function SameWbDetail() As String 
    Rem display routine 
    SameWbDetail = SameWbDetail & "There are " & SameWbOtherSheetRefs.Count & " ref.s to other sheets in the same book." 
    SameWbDetail = SameWbDetail & vbCr & "They appear in this order, including duplications:" & vbCrLf & vbCrLf 
    SameWbDetail = SameWbDetail & rrayStr(SameWbOtherSheetRefs, vbCr) 
    SameWbDetail = SameWbDetail & vbCrLf & vbCrLf & "There are " & SameWbSameSheetRefs.Count & " precedents on the same sheet." 
    SameWbDetail = SameWbDetail & vbCr & "They are (out of order, duplicates not noted):" & vbCrLf & vbCrLf 
    SameWbDetail = SameWbDetail & rrayStr(SameWbSameSheetRefs, vbCr) 
End Function 
Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String) 
    Rem display routine 
    Dim xVal As Variant 
    If IsEmpty(inputRRay) Then Exit Function 
    If Delimiter = vbNullString Then Delimiter = " " 
    For Each xVal In inputRRay 
        rrayStr = rrayStr & Delimiter & xVal 
    Next xVal 
    rrayStr = Mid(rrayStr, Len(Delimiter) + 1) 
End Function

推荐答案

(v0.2)现在显示错误消息.

(v0.2) Now displays error messages.

(v0.3)现在可以完全追溯到硬编码的值.

(v0.3) Now does a full trace back to hard-coded values.

除了有趣的事情之外，如果您真的想一路追溯到硬编码的值，最好的方法是编写一个主要的RunMe_Controller子控件来控制原始代码.与钩子函数(和一些辅助函数)一起，这实际上是利用现有代码的最简单方法.

All fun aside, if you're serious about tracing all the way back to a hard-coded value, the best way is to write a main RunMe_Controller sub to control the original code. Together with a hook function (and some helper function), this is actually the simplest way to leverage the existing code.

MsgBoxInterceptor()函数足够聪明，可以允许通过错误消息，但会静默捕获所有其他MsgBox()调用.

The MsgBoxInterceptor() function is smart enough to allow error messages through but silently traps all other MsgBox() calls.

有关更多重要信息，请参见答案底部的部分.

See the section at the bottom of the answer for further important details.

安装:

• 将 已修复新错误的 代码块复制/粘贴到模块中；
• 将以下更新的代码块的v0.3插入指示的先前代码中；
• 执行当前模块"，仅查找整个单词"以搜索MsgBox并替换为MsgBoxInterceptor;
• 将以下两个引用添加到VBA项目.
  • Microsoft VBScript正则表达式5.5
  • Microsoft脚本运行时
  • Copy/paste the new bug-fixed RunMe code block to a module;
  • Insert v0.3 of the following updated code block into the previous code where indicated;
  • Do a "Current Module", "Find Whole Words Only" search for MsgBox with replacement MsgBoxInterceptor;
  • Add the following two references to the VBA project.
    • Microsoft VBScript Regular Expressions 5.5
    • Microsoft Scripting Runtime

    代码:

    '===============================================================================
    ' Module     : <in any standard module>
    ' Version    : 0.3
    ' Part       : 1 of 1
    ' References : Microsoft VBScript Regular Expressions 5.5
    '            : Microsoft Scripting Runtime
    ' Online     : https://stackoverflow.com/a/46036068/1961728
    '===============================================================================
    Private Const l_No_transformation As String = "No transformation"
    Private Enum i_
        z__NONE = 0
      SourceCell
      SourceSheet
      SourceBook
      TargetCell
      TargetSheet
      TargetBook
      Formula
      Index
      SourceRef
        z__NEXT
        z__FIRST = z__NONE + 1
        z__LAST = z__NEXT - 1
    End Enum
    Private meMsgBoxResult As VBA.VbMsgBoxResult
    'v0.3
    Public Sub RunMe_Controller()
    
      Const s_Headers   As String = "Source Cell::Source Sheet::Source Book::Target Cell::Target Sheet::Target Book::Formula"
      Const s_Separator As String = "::"
      Const l_Circular  As String = "Circular"
    
      Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
      Dim dictFullRefTrace As Scripting.Dictionary  '##Early Bound## As Object
      Dim varRootRef As Variant
      Dim varTargetRef As Variant
      Dim varSavedTraceStepKey As Variant
      Dim varNewTraceStep As Variant
      Dim strNewKey As String
    
      Application.ScreenUpdating = False 'Set to true for psychedelic display
      Set dictFullRefTrace = New Dictionary         '##Early Bound## = CreateObject("Scripting.Dictionary")
      varRootRef = ActiveCell.Address(External:=True)
      dictFullRefTrace.Add varRootRef & s_Separator & s_Separator, TheRefTraceStepAsArray(varRootRef)
      dictFullRefTrace.Add s_Separator & s_Separator, TheRefTraceStepAsArray() 'Need two trace steps in dict to start dynamic expansion
      For Each varSavedTraceStepKey In dictFullRefTrace: Do  ' Can't use .Items as it is not dynamically expanded
        If varSavedTraceStepKey = s_Separator & s_Separator Then ' Dummy trace step (dict exhausted) -> clean up fake trace steps
          dictFullRefTrace.Remove varRootRef & s_Separator & s_Separator
          dictFullRefTrace.Remove s_Separator & s_Separator
          Exit Do
        End If
        varTargetRef = dictFullRefTrace(varSavedTraceStepKey)(i_.SourceRef)
        Select Case True
          Case varTargetRef Like "'?:*": ' Closed Wb -> ignore for now (TODO - auto open it)
            Exit Do
          Case varSavedTraceStepKey Like "*#": ' "No transformation" (from its own trace step) -> ignore
            Exit Do
          Case varSavedTraceStepKey Like "*" & l_Circular: ' "Circular" (from its own trace step) -> ignore
            Exit Do
        End Select
        meMsgBoxResult = vbOK
        FindCellPrecedents Evaluate(varTargetRef) ' ~= RunMe() - leverage the existing code to update the global Ref Collections
        Select Case meMsgBoxResult
          Case vbOK:
            For Each varNewTraceStep In TheNewTraceSteps(fromTarget:=varTargetRef).Items
              strNewKey = varNewTraceStep(i_.SourceRef) & s_Separator & varTargetRef & s_Separator
              If dictFullRefTrace.Exists(strNewKey) Then ' Target is a circular ref -> mark it and then add it
                strNewKey = strNewKey & l_Circular
                varNewTraceStep(i_.Formula) = l_Circular
              End If
              If Not dictFullRefTrace.Exists(strNewKey) Then ' Ignore subsequent circular refs for this target
                dictFullRefTrace.Add strNewKey, varNewTraceStep
              End If
            Next varNewTraceStep
          Case vbIgnore: ' No transformation - typically occurs multiple times, so need multiple unique keys
            varNewTraceStep = TheRefTraceStepAsArray(varTargetRef, varTargetRef)
            strNewKey = varTargetRef & s_Separator & varTargetRef & s_Separator & varNewTraceStep(i_.Index)
            dictFullRefTrace.Add strNewKey, varNewTraceStep
          Case vbAbort: ' Error occurred and message was displayed
            Exit Sub
          Case Else
            ' Never
        End Select
        ' Move dummy trace step to end
        dictFullRefTrace.Remove s_Separator & s_Separator
        dictFullRefTrace.Add s_Separator & s_Separator, vbNullString
      Loop While 0: Next varSavedTraceStepKey
      ' Create, fill and format worksheet
      With Evaluate(varRootRef)
        .Worksheet.Parent.Activate
         Worksheets.Add after:=.Worksheet
      End With
      With ActiveSheet.Rows(1).Resize(ColumnSize:=i_.Index - i_.z__FIRST + 1)
        .Value2 = Split(s_Headers, s_Separator)
        .Font.Bold = True
        With .Offset(1).Resize(RowSize:=dictFullRefTrace.Count)
          .Cells.Value = ƒ.Transpose(ƒ.Transpose(dictFullRefTrace.Items)) ' Fill
          .Sort .Columns(i_.Index), xlDescending, Header:=xlNo
        End With
        With .EntireColumn
          .Columns(i_.Formula).Copy
          .Columns(i_.Index).PasteSpecial Paste:=xlPasteValues
          .Columns(i_.Formula).Delete
          .Columns(i_.SourceCell).HorizontalAlignment = xlCenter
          .Columns(i_.TargetCell).HorizontalAlignment = xlCenter
          .AutoFilter i_.Formula, l_Circular
          .Columns(i_.Formula).SpecialCells(xlCellTypeConstants).Font.Color = vbRed
          .AutoFilter i_.Formula, l_No_transformation
          .Columns(i_.Formula).SpecialCells(xlCellTypeConstants).Font.Bold = True
          .AutoFilter
          .Rows(1).Font.ColorIndex = xlAutomatic
          .AutoFit
        End With
        .Cells(1).Select
      End With
      Application.ScreenUpdating = True
    
    End Sub
    
    Private Function TheNewTraceSteps _
                     ( _
                       Optional ByRef fromTarget As Variant _
                     ) _
            As Scripting.Dictionary                        '##Early Bound## As Object
            Dim pvarTargetRef As Variant: pvarTargetRef = fromTarget
    
      Dim mtchMultiCellAddress As VBScript_RegExp_55.Match '##Early Bound## As Object
      Dim strFormula As String
      Dim rngCell As Range
      Dim strKey As String
      Dim astrTraceStep() As String
      Dim varRunMeSourceRef As Variant
      Dim varRefCollection As Variant
    
      Set TheNewTraceSteps = New Dictionary                '##Early Bound## = CreateObject("Scripting.Dictionary")
      strFormula = Evaluate(pvarTargetRef).Formula
      With New VBScript_RegExp_55.RegExp                   '##Early Bound## = CreateObject("VBScript_RegExp_55.RegExp")
        .Global = True
        .Pattern = "(?:(?:[:]| *)(?:\$?[A-Z]{1,3}\d+:\$?[A-Z]{1,3}\d+))+"
        If .test(strFormula) Then
          For Each mtchMultiCellAddress In .Execute(strFormula)
            For Each rngCell In Evaluate(mtchMultiCellAddress.Value)
              strKey = rngCell.Address
              If Not TheNewTraceSteps.Exists(strKey) Then
                astrTraceStep = TheRefTraceStepAsArray(rngCell.Address(External:=True), pvarTargetRef)
                TheNewTraceSteps.Add strKey, astrTraceStep
              End If
            Next rngCell
          Next mtchMultiCellAddress
        End If
      End With
      For Each varRefCollection In Array(SameWbSameSheetRefs, SameWbOtherSheetRefs, OtherWbRefs)
        For Each varRunMeSourceRef In varRefCollection
          strKey = Evaluate(varRunMeSourceRef).Address
          If Not TheNewTraceSteps.Exists(strKey) Then
            astrTraceStep = TheRefTraceStepAsArray(varRunMeSourceRef, pvarTargetRef)
            TheNewTraceSteps.Add strKey, astrTraceStep
          End If
          varRefCollection.Remove 1
        Next varRunMeSourceRef
      Next varRefCollection
    
    End Function
    
    Private Function TheRefTraceStepAsArray _
                     ( _
                       Optional ByRef SourceRef As Variant = vbNullString, _
                       Optional ByRef TargetRef As Variant = vbNullString _
                     ) _
            As String()
    
      Static slngIndex As Long ' Required for reverse ordering of trace output
    
      Dim pvarSourceRef As String: pvarSourceRef = Replace(SourceRef, "''", "'")
      Dim pvarTargetRef As String: pvarTargetRef = Replace(TargetRef, "''", "'")
      Dim astrTraceStepValues() As String: ReDim astrTraceStepValues(1 To i_.z__LAST)
      Dim strFormula As String: strFormula = vbNullString
      Dim astrSourceCellSheetBook() As String
      Dim astrTargetCellSheetBook() As String
    
      astrSourceCellSheetBook = Ref2CellSheetBook(pvarSourceRef)
      astrTargetCellSheetBook = Ref2CellSheetBook(pvarTargetRef)
      If pvarSourceRef = vbNullString _
      Or pvarTargetRef = vbNullString _
      Then
    '    slngIndex = 0 ' Dummy or root ref, i.e., new trace started -> intialize static variable
      Else
        slngIndex = slngIndex + 1
        With Evaluate(TargetRef)
          strFormula = IIf(.HasFormula And pvarSourceRef <> pvarTargetRef, "'" & Mid$(.Formula, 2), l_No_transformation)
        End With
      End If
    
      astrTraceStepValues(i_.SourceCell) = astrSourceCellSheetBook(1)
      astrTraceStepValues(i_.SourceSheet) = astrSourceCellSheetBook(2)
      astrTraceStepValues(i_.SourceBook) = astrSourceCellSheetBook(3)
      astrTraceStepValues(i_.TargetCell) = astrTargetCellSheetBook(1)
      astrTraceStepValues(i_.TargetSheet) = astrTargetCellSheetBook(2)
      astrTraceStepValues(i_.TargetBook) = astrTargetCellSheetBook(3)
      astrTraceStepValues(i_.Formula) = strFormula
      astrTraceStepValues(i_.Index) = slngIndex
      astrTraceStepValues(i_.SourceRef) = SourceRef
      TheRefTraceStepAsArray = astrTraceStepValues
    
    End Function
    
    Private Function Ref2CellSheetBook(ByRef Ref As Variant) As String()
      Dim × As Long: × = 4
      Dim astrCellSheetBook() As String: ReDim astrCellSheetBook(1 To i_.z__LAST)
      If IsMissing(Ref) Then GoTo ExitFunction:
      × = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "[") + 1, Abs(InStr(Ref, "]") - InStr(Ref, "[") - 1))
      × = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "]") + 1, Abs(InStr(Ref, "!") - InStr(Ref, "]") - 2))
      × = × - 1: astrCellSheetBook(×) = Mid$(Ref, InStr(Ref, "!") + 1)
      astrCellSheetBook(×) = Replace(astrCellSheetBook(×), "$", "")
    ExitFunction:
      Ref2CellSheetBook = astrCellSheetBook
    End Function
    
    Private Function MsgBoxInterceptor _
                    ( _
                               Prompt, _
                      Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
                      Optional Title, _
                      Optional HelpFile, _
                      Optional Context _
                    ) _
            As VBA.VbMsgBoxResult
    
      If Buttons = vbOKOnly _
      Then
        If Prompt Like "*does not contain a formula*" _
        Or Prompt Like "*contains a formula with no precedents*" _
        Then
          meMsgBoxResult = vbIgnore
        Else
          meMsgBoxResult = vbAbort
          MsgBox Prompt, Buttons, Title, HelpFile, Context
        End If
      End If
      MsgBoxInterceptor = vbCancel
    End Function
    

    ---

    错误修复的原始代码:

    Option Explicit
    Public OtherWbRefs As Collection
    Public ClosedWbRefs As Collection
    Public SameWbOtherSheetRefs As Collection
    Public SameWbSameSheetRefs As Collection
    Public CountOfClosedWb As Long
    Dim headerString As String
    
    ' <--  Insert other code here
    
    Sub RunMe()
        Call FindCellPrecedents(ActiveCell)
    End Sub
    
    Sub FindCellPrecedents(homeCell As Range)
        Dim i As Long, j As Long, pointer As Long
        Dim maxReferences As Long
        Dim outStr As String
        Dim userInput As Long
    
        If homeCell.HasFormula Then
            Set OtherWbRefs = New Collection: CountOfClosedWb = 0
            Set SameWbOtherSheetRefs = New Collection
            Set SameWbSameSheetRefs = New Collection
    
            Rem find closed precedents from formula String
            Call FindClosedWbReferences(homeCell)
    
            Rem find Open precedents from navigate arrows
            homeCell.Parent.ClearArrows
            homeCell.ShowPrecedents
            headerString = "in re: the formula in " & homeCell.Address(, , , True)
            maxReferences = Int(Len(homeCell.Formula) / 3) + 1
    On Error GoTo LoopOut:
            For j = 1 To maxReferences
                homeCell.NavigateArrow True, 1, j
                If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then
                    Rem closedRef
                    Call CategorizeReference("<ClosedBook>", homeCell)
                Else
                    Call CategorizeReference(ActiveCell, homeCell)
                End If
            Next j
    LoopOut:
    
            On Error GoTo 0
            For j = 2 To maxReferences
                homeCell.NavigateArrow True, j, 1
                If ActiveCell.Address(, , , True) = homeCell.Address(, , , True) Then Exit For
                Call CategorizeReference(ActiveCell, homeCell)
            Next j
            homeCell.Parent.ClearArrows
    
            Rem integrate ClosedWbRefs (from parsing) With OtherWbRefs (from navigation)
            If ClosedWbRefs.Count <> CountOfClosedWb Then '#robinCTS#' Should read (ParsedClosedWbRefs <> CountOfNavigatedClosedWbRefs)
                If ClosedWbRefs.Count = 0 Then
                    MsgBoxInterceptor homeCell.Address(, , , True) & " contains a formula with no precedents."
                    Exit Sub
                Else
                    MsgBoxInterceptor "string-" & ClosedWbRefs.Count & ":nav " & CountOfClosedWb
                    MsgBoxInterceptor "Methods find different # of closed precedents."
                    End
                End If
            End If
    
            pointer = 1
            For j = 1 To OtherWbRefs.Count
                If OtherWbRefs(j) Like "<*" Then
                    OtherWbRefs.Add Item:=ClosedWbRefs(pointer), Key:="closed" & CStr(pointer), after:=j
                    pointer = pointer + 1
                    OtherWbRefs.Remove j
                End If
            Next j
    
            Rem present findings
            outStr = homeCell.Address(, , , True) & " contains a formula with:"
            outStr = outStr & vbCrLf & vbCrLf & CountOfClosedWb & " precedents in closed workbooks."
            outStr = outStr & vbCr & (OtherWbRefs.Count - CountOfClosedWb) & " precedents in other workbooks that are open."
            outStr = outStr & vbCr & SameWbOtherSheetRefs.Count & " precedents on other sheets in the same workbook."
            outStr = outStr & vbCr & SameWbSameSheetRefs.Count & " precedents on the same sheet."
            outStr = outStr & vbCrLf & vbCrLf & "YES - See details about Other Books."
            outStr = outStr & vbCr & "NO - See details about The Active Book."
            Do
                userInput = MsgBoxInterceptor(Prompt:=outStr, Title:=headerString, Buttons:=vbYesNoCancel + vbDefaultButton3)
                Select Case userInput
                Case Is = vbYes
                    MsgBoxInterceptor Prompt:=OtherWbDetail(), Title:=headerString, Buttons:=vbOKOnly
                Case Is = vbNo
                    MsgBoxInterceptor Prompt:=SameWbDetail(), Title:=headerString, Buttons:=vbOKOnly
                End Select
            Loop Until userInput = vbCancel
        Else
            MsgBoxInterceptor homeCell.Address(, , , True) & vbCr & " does not contain a formula."
        End If
    End Sub
    
    Sub CategorizeReference(Reference As Variant, Home As Range)
        Rem assigns reference To the appropriate collection
        If TypeName(Reference) = "String" Then
            Rem String indicates reference To closed Wb
            OtherWbRefs.Add Item:=Reference, Key:=CStr(OtherWbRefs.Count)
            CountOfClosedWb = CountOfClosedWb + 1
        Else
            If Home.Address(, , , True) = Reference.Address(, , , True) Then Exit Sub '#robinCTS#' Never true as same check done in caller
            If Home.Parent.Parent.Name = Reference.Parent.Parent.Name Then
                Rem reference In same Wb
                If Home.Parent.Name = Reference.Parent.Name Then
                    Rem sameWb sameSheet
                    SameWbSameSheetRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(SameWbSameSheetRefs.Count)
                Else
                    Rem sameWb Other sheet
                    SameWbOtherSheetRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(SameWbOtherSheetRefs.Count)
                End If
            Else
                Rem reference To other Open Wb
                OtherWbRefs.Add Item:=Reference.Address(, , , True), Key:=CStr(OtherWbRefs.Count)
            End If
        End If
    End Sub
    
    Sub FindClosedWbReferences(inRange As Range) '#robinCTS#' Should read FindParsedOtherWbReferences
        Rem fills the collection With closed precedents parsed from the formula String
        Dim testString As String, returnStr As String, remnantStr As String
        testString = inRange.Formula
        Set ClosedWbRefs = New Collection
    
        Do
            returnStr = NextClosedWbRefStr(testString, remnantStr)
            ClosedWbRefs.Add Item:=returnStr, Key:=CStr(ClosedWbRefs.Count)
            testString = remnantStr
        Loop Until returnStr = vbNullString '#robinCTS#' Better if add " Or testString = vbNullString"
    
        ClosedWbRefs.Remove ClosedWbRefs.Count '#robinCTS#' then this no longer required
    End Sub
    Function NextClosedWbRefStr(FormulaString As String, Optional ByRef Remnant As String) As String
        Dim workStr As String
        Dim start As Long, interval As Long, del As Long
        For start = 1 To Len(FormulaString)
            For interval = 2 To Len(FormulaString) - start + 1
                workStr = Mid(FormulaString, start, interval)
                If workStr Like Chr(39) & "[![]*[[]*'![$A-Z]*#" Then        '#robinCTS#' Original was "[!!]*'![$A-Z]*#"
                    If workStr Like Chr(39) & "[![]*[[]*'!*[$1-9A-Z]#" Then '#robinCTS#' Original was "[!!]*'!*[$1-9A-Z]#" Not required?
                        interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "#") '#robinCTS#' Not required as always Like "*#" here?
                        interval = interval - 3 * CLng(Mid(FormulaString, start + interval, 1) = ":")
                        interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
                        interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
                        interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
                        interval = interval - CLng(Mid(FormulaString, start + interval, 1) Like "[$1-9A-Z]")
                        NextClosedWbRefStr = Mid(FormulaString, start, interval)
                        Remnant = Mid(FormulaString, start + interval)
                        Exit Function
                    End If
                End If
            Next interval
        Next start
    End Function
    
    Function OtherWbDetail() As String
        Rem display routine
        OtherWbDetail = OtherWbDetail & "There are " & OtherWbRefs.Count & " references to other workbooks. "
        OtherWbDetail = OtherWbDetail & IIf(CBool(CountOfClosedWb), CountOfClosedWb & " are closed.", vbNullString)
        OtherWbDetail = OtherWbDetail & vbCr & "They appear in the formula in this order:" & vbCrLf & vbCrLf
        OtherWbDetail = OtherWbDetail & rrayStr(OtherWbRefs, vbCr)
    End Function
    Function SameWbDetail() As String
        Rem display routine
        SameWbDetail = SameWbDetail & "There are " & SameWbOtherSheetRefs.Count & " ref.s to other sheets in the same book."
        SameWbDetail = SameWbDetail & vbCr & "They appear in this order, including duplications:" & vbCrLf & vbCrLf
        SameWbDetail = SameWbDetail & rrayStr(SameWbOtherSheetRefs, vbCr)
        SameWbDetail = SameWbDetail & vbCrLf & vbCrLf & "There are " & SameWbSameSheetRefs.Count & " precedents on the same sheet."
        SameWbDetail = SameWbDetail & vbCr & "They are (out of order, duplicates not noted):" & vbCrLf & vbCrLf
        SameWbDetail = SameWbDetail & rrayStr(SameWbSameSheetRefs, vbCr)
    End Function
    Function rrayStr(ByVal inputRRay As Variant, Optional Delimiter As String)
        Rem display routine
        Dim xVal As Variant
        If IsEmpty(inputRRay) Then Exit Function
        If Delimiter = vbNullString Then Delimiter = " "
        For Each xVal In inputRRay
            rrayStr = rrayStr & Delimiter & xVal
        Next xVal
        rrayStr = Mid(rrayStr, Len(Delimiter) + 1)
    End Function
    

    问题:

    • 已关闭的工作簿尚未自动打开
    • 引用关闭的工作簿的公式将显示路径名
    • 引用打开的工作簿的公式不会显示路径名，与您的示例不同
    • 仅扩展简单的硬编码多单元格范围(目前)
    • 还不扩展整个列或行，仅获取第一个单元格
    • 找不到/扩展INDEX，OFFSET或任何其他类似的计算范围
    • 未对扩展范围进行排序，可能无法很好地排序.
    • Closed workbooks are not auto-opened (yet)
    • Formulas referencing closed workbooks will display the pathname
    • Formulas referencing open workbooks won't display the pathname, unlike your example
    • Only expands simple hard-coded multi-cell ranges (for now)
    • Doesn't expand whole columns or rows, yet, only grabs the first cell
    • Doesn't find/expand INDEX, OFFSET or any other similar calculated ranges
    • Expanded ranges are not sorted any may not be ordered nicely.

    功能/增强:

    • RunMe代码错误修复现在可以根据请求正确检测关闭的工作簿引用
    • 现在，简单的多单元格范围可以按要求扩展
    • 正确引用了循环引用
    • 硬编码的值按要求显示粗体的无变换"
    • 如果从多个目标访问，则硬编码值会显示多次
    • 正确处理工作表名称中的撇号
    • RunMe code bugfixes now allow proper detection of closed workbook refs as requested
    • Simple multi-cell ranges now expand out as requested
    • Circular references are properly accounted for
    • Hard-coded values show a bold "No transformation" as requested
    • Hard-coded values display multiple times if accessed from multiple targets
    • Apostrophes in sheet names are properly taken care of

    注意:如果您对我的变量命名约定感到好奇，它基于 RVBA .

    这篇关于Excel VBA代码可跟踪单元的先例的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！