Excel VBA代码可跟踪单元的先例

Question

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

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

我是否应该创建一个新函数来创建一个新工作表并将动态信息复制到第一个子目录中？

例如，如果我在Sheet1的单元格C1中具有公式A1 + B1 ，那么我想要在Sheet2（新创建的工作表）中的一行，其中将目标单元格显示为C1 ，将目标工作表显示为Sheet1 ，将源单元格显示为A1 ，将源工作表显示为Sheet1 。 我还希望Sheet2中的另一行将目标单元格显示为C1 ，将目标表显示为Sheet1 ，将源单元格显示为B1 ，将源工作表显示为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

Answer 1

编辑： （v0.2）现在显示错误消息。

编辑： （v0.3）现在进行完整追溯到硬编码值。

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

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

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

安装：

将新的错误修复的 RunMe代码块复制/粘贴到模块中；
将以下更新的代码块的v0.3插入指示的先前代码中；
在“当前模块”，“仅查找全字”中搜索带有替换MsgBoxInterceptor MsgBox ；
将以下两个引用添加到VBA项目。
- Microsoft VBScript正则表达式5.5
- Microsoft脚本运行时

码：

'===============================================================================
' 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或任何其他类似的计算范围
扩展范围未排序，可能未正确排序。

功能/增强功能：

RunMe代码错误修复程序现在允许按要求正确检测关闭的工作簿引用
现在可以根据要求扩展简单的多单元格范围
循环引用已正确说明
硬编码的值按要求显示粗体的“无变换”
如果从多个目标访问，则硬编码值将显示多次
正确处理工作表名称中的撇号

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

Answer 2

我相信最好添加两个新功能：

添加“信息表”（并将其存储在变量中以备后用）

 Sub addInfoSheet() Dim oldSheet Set oldSheet = ActiveSheet Sheets.Add After:=ActiveSheet Set infoSheet = Sheets(ActiveSheet.Index) oldSheet.Select End Sub

将一行存储到工作表的子，例如：

 Sub addRowToInfoSheet(targetSheet As String, targetRange As String, sourceSheet As String, sourceRange As String) infoSheet.Cells(rowInInfoSheet, 1) = targetSheet infoSheet.Cells(rowInInfoSheet, 2) = targetRange infoSheet.Cells(rowInInfoSheet, 3) = sourceSheet infoSheet.Cells(rowInInfoSheet, 4) = sourceRange rowInInfoSheet = rowInInfoSheet + 1 End Sub

让我知道是否有帮助。

Answer 3

编辑： （v0.2）现在适用于当前工作簿中的所有工作表。 （然后充实其他工作簿。）

您可以偷偷摸摸地挂上MsgBox函数，并从其输出中解析数据。

只需在代码中全局搜索MsgBox并将其替换为例如MsgBoxInterceptor 。

然后编写MsgBoxInterceptor()函数，哦，就像下面的代码一样说;）

RunMe()运行RunMe()子，瞧！ 而不是输出到屏幕，您将输出到新的工作表。

甚至无需弄清楚您的原始代码在做什么！

注意：提供的功能仅从活动工作簿中提取先例。

'v0.2
Private Function MsgBoxInterceptor _
                ( _
                           Prompt, _
                  Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
                  Optional Title, _
                  Optional HelpFile, _
                  Optional Context _
                ) _
        As VBA.VbMsgBoxResult

  Const i_TargetCell  As Long = 1
  Const i_TargetSheet As Long = 2
  Const i_SourceCell  As Long = 3
  Const i_SourceSheet As Long = 4

  Static slngState As Long
  Static srngDataRow As Range
  Static sstrTargetCell As String
  Static sstrTargetSheet As String
  Static slngClosedBookCount As Long
  Static slngOpenBookCount As Long
  Static slngSameBookCount As Long
  Static slngSameSheetCount As Long

  Dim f As WorksheetFunction: Set f = WorksheetFunction
  Dim lngBegin As Long
  Dim lngEnd As Long
  Dim i As Long

  Select Case slngState
    Case 0: ' Get counts and target
      Worksheets.Add After:=ActiveSheet
      Set srngDataRow = ActiveSheet.Range("A1:D1")
      srngDataRow.Value = Split("Target Cell:Target Sheet:Source Cell:Source Sheet", ":")
      Set srngDataRow = srngDataRow.Offset(1)

      lngBegin = InStr(1, Prompt, "]") + 1
      lngEnd = InStr(lngBegin, Prompt, "'")
      sstrTargetSheet = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
      srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet

      lngBegin = InStr(lngEnd, Prompt, "$") + 1
      lngEnd = InStr(lngBegin, Prompt, " ")
      sstrTargetCell = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")
      srngDataRow.Cells(i_TargetCell) = sstrTargetCell

      lngBegin = InStr(lngEnd, Prompt, ":") + 3
      lngEnd = InStr(lngBegin, Prompt, " ")
      slngClosedBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))

      lngBegin = InStr(lngEnd, Prompt, ".") + 2
      lngEnd = InStr(lngBegin, Prompt, " ")
      slngOpenBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))

      lngBegin = InStr(lngEnd, Prompt, ".") + 2
      lngEnd = InStr(lngBegin, Prompt, " ")
      slngSameBookCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))

      lngBegin = InStr(lngEnd, Prompt, ".") + 2
      lngEnd = InStr(lngBegin, Prompt, " ")
      slngSameSheetCount = Val(Mid$(Prompt, lngBegin, lngEnd - lngBegin))

      slngState = slngState + 1
      MsgBoxInterceptor = vbNo
    Case 1: ' Get same book sources
      lngEnd = InStr(1, Prompt, "[")
      For i = 1 To slngSameBookCount
        srngDataRow.Cells(i_TargetCell) = sstrTargetCell
        srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet

        lngBegin = InStr(lngEnd, Prompt, "]") + 1
        lngEnd = InStr(lngBegin, Prompt, "'")
        srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)

        lngBegin = InStr(lngEnd, Prompt, "$") + 1
        lngEnd = InStr(lngBegin, Prompt, Chr$(13))
        srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")

        Set srngDataRow = srngDataRow.Offset(1)
      Next i
      For i = 1 To slngSameSheetCount
        srngDataRow.Cells(i_TargetCell) = sstrTargetCell
        srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet

        lngBegin = InStr(lngEnd, Prompt, "]") + 1
        lngEnd = InStr(lngBegin, Prompt, "'")
        srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)

        lngBegin = InStr(lngEnd, Prompt, "$") + 1
        lngEnd = InStr(lngBegin, Prompt, Chr$(13))
        If lngEnd = 0 Then lngEnd = Len(Prompt) + 1
        srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")

        Set srngDataRow = srngDataRow.Offset(1)
      Next i
      slngState = slngState + 1
      MsgBoxInterceptor = vbOK
    Case 2: ' Just skipping through
      slngState = slngState + 1
      MsgBoxInterceptor = vbYes
    Case 3: 'Get other book sources (STILL TODO)
      lngEnd = InStr(1, Prompt, "")
      For i = 1 To slngClosedBookCount
        srngDataRow.Cells(i_TargetCell) = sstrTargetCell
        srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet

'        lngBegin = InStr(lngEnd, Prompt, "]") + 1
'        lngEnd = InStr(lngBegin, Prompt, "'")
'        srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
'
'        lngBegin = InStr(lngEnd, Prompt, "$") + 1
'        lngEnd = InStr(lngBegin, Prompt, Chr$(13))
'        srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")

        Set srngDataRow = srngDataRow.Offset(1)
      Next i
      For i = 1 To slngOpenBookCount
        srngDataRow.Cells(i_TargetCell) = sstrTargetCell
        srngDataRow.Cells(i_TargetSheet) = sstrTargetSheet

'        lngBegin = InStr(lngEnd, Prompt, "]") + 1
'        lngEnd = InStr(lngBegin, Prompt, "'")
'        srngDataRow.Cells(i_SourceSheet) = Mid$(Prompt, lngBegin, lngEnd - lngBegin)
'
'        lngBegin = InStr(lngEnd, Prompt, "$") + 1
'        lngEnd = InStr(lngBegin, Prompt, Chr$(13))
'        If lngEnd = 0 Then lngEnd = Len(Prompt) + 1
'        srngDataRow.Cells(i_SourceCell) = f.Substitute(Mid$(Prompt, lngBegin, lngEnd - lngBegin), "$", "")

        Set srngDataRow = srngDataRow.Offset(1)
      Next i
      slngState = slngState + 1
      MsgBoxInterceptor = vbOK
    Case 4: ' Finished -> tidy up
      srngDataRow.EntireColumn.AutoFit
      slngState = 0
      MsgBoxInterceptor = vbCancel
    Case Else
  End Select

End Function

说明：

此代码的关键是使用通过Static关键字创建的静态变量。 即使在VBA停止运行并重新启动后，它们仍保留其值。 它们在代码中用于允许构造状态机，该状态机模仿了用户与消息框交互的固定顺序。

剩下的只是MsgBox消息的字符串解析。

Excel VBA代码可跟踪单元的先例

问题描述

3 个解决方案

解决方案1
1 2017-09-04 11:29:30

解决方案2
0 2017-09-03 17:28:38

解决方案3
0 2017-09-03 20:01:33

Excel VBA代码可跟踪单元的先例

问题描述

3 个解决方案

解决方案1 1 2017-09-04 11:29:30

解决方案2 0 2017-09-03 17:28:38

解决方案3 0 2017-09-03 20:01:33

解决方案1
1 2017-09-04 11:29:30

解决方案2
0 2017-09-03 17:28:38

解决方案3
0 2017-09-03 20:01:33