Question

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

我是VBA的新手，我想请求有关更改此代码的帮助，以便在活动工作表之后将先前的单元格，公式和地址吐出到新的工作表中。请有人帮我理解如何做到这一点。

我是否应该创建一个新功能来创建新工作表并在第一个子工作区内将动态信息复制到其中？

例如，如果我在Sheet1的单元格A1 + B1中有公式C1，那么我想在Sheet2（新创建的工作表）中显示一行，其中Target Cell显示为C1，目标工作表为Sheet1，源单元格为A1，源表格为Sheet1。我还想在Sheet2中另一行显示Target Cell为C1，Target Sheet为Sheet1，Source Cell为B1，Source Sheet为Sheet1。

Sheet 2中：

代码：

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插入前面的代码中;
执行“当前模块”，“仅查找整个单词”搜索MsgBox并替换MsgBoxInterceptor;
将以下两个引用添加到VBA项目中。
- 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或任何其他类似的计算范围
扩展范围未排序任何可能无法正常订购。

功能/增强

RunMe代码错误修正现在允许按要求正确检测已关闭的工作簿引用

简单的多单元格范围现在按要求扩展

正确说明循环引用

硬编码值按要求显示粗体“无转换”

如果从多个目标访问，则硬编码值会多次显示

工作表名称中的撇号正确处理

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

Answer 2

我认为最好添加两个新功能：

添加＆＃34;信息表＆＃34; （并将其存储在变量中供以后使用）

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() sub，瞧！您可以输出到新的工作表，而不是输出到屏幕。

甚至无需弄清楚原始代码的作用！

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

'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 个答案: