Excel VBA代码来跟踪单元格的先例
我有以下代码跟踪活动单元格的先例，并吐出一个消息框与信息。 （它还在其他工作表和工作簿中search先例）。
我是VBA的新手，我想请求帮助更改此代码，以便在活动工作表之后将先前的单元格，公式和地址吐出到新的工作表中。 请有人可以帮助我了解如何做到这一点。
我应该创build一个新的function来创build一个新的工作表，并将dynamic信息复制到第一个子内？
例如，如果我在Sheet1的单元格C1中具有公式A1 + B1 ，则需要在Sheet2（新创build的工作表）中将目标单元格显示为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) & "[!!]*'![$AZ]*#" 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.3）现在做一个完整的追溯到硬编码值。
除此之外，如果你认真追踪硬编码值，最好的方法是编写一个主RunMe_Controller子来控制原始代码。 与一个钩子函数（和一些辅助函数）一起，这实际上是利用现有代码的最简单的方法。
MsgBoxInterceptor()函数足够聪明，允许通过错误消息，但静静地陷阱所有其他MsgBox()调用。
有关更多重要细节，请参阅答案底部的部分。
安装：
- 复制/粘贴新的bug修复
RunMe代码块到模块; - 将以下更新的代码块的v0.3插入前面的代码中;
- 做一个“当前模块”，“查找整个单词”search与replace
MsgBoxInterceptorMsgBox; - 将以下两个引用添加到VBA项目。
- Microsoft VBScript正则expression式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 = "(?:(?:[:]| *)(?:\$?[AZ]{1,3}\d+:\$?[AZ]{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, ie, 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
Bug修复的原始代码：
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) & "[![]*[[]*'![$AZ]*#" Then '#robinCTS#' Original was "[!!]*'![$AZ]*#" 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
问题：
- 已closures的工作簿未自动打开（尚）
- 引用已closures工作簿的公式将显示path名
- 引用打开工作簿的公式不会显示path名，与您的示例不同
- 只扩展简单的硬编码多单元格范围（现在）
- 不扩展整列或行，但只抓取第一个单元格
- 找不到/扩展
INDEX，OFFSET或任何其他类似的计算范围 - 扩大范围不sorting任何可能不会很好地sorting。
function/增强function：
-
RunMe代码错误修正现在允许按要求正确检测已closures的工作簿参考 - 简单的多单元格范围现在按要求展开
- 循环引用适当考虑
- 硬编码的值按要求显示一个粗体的“不转换”
- 如果从多个目标访问，硬编码值会显示多次
- 表格中的撇号已妥善保pipe
注意：如果您对我的variables命名惯例感到好奇，它基于RVBA 。
我相信最好添加两个新function：
-
添加“信息表”（并将其存储在一个variables供以后使用）
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
让我知道这是否有帮助。
编辑： （v0.2）现在适用于当前工作簿中的所有工作表。 （并为其他工作簿充实。）
你可以做一些鬼鬼祟祟的事情，挂钩MsgBox函数并从输出中parsing数据。
只需在您的代码中进行MsgBox的全局search，并将其replace为，例如MsgBoxInterceptor 。
然后你编写MsgBoxInterceptor()函数，哦，像下面这样说;）
像正常运行RunMe()子，瞧！ 输出到屏幕，而不是输出到一个新的工作表。
没有必要甚至解决你的原代码在做什么！
注意：所提供的function只能从活动工作簿中拉取先例。
'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
说明：
The key to this code is the use of static variables, created with the Static keyword. These retain their values even after VBA stops running and is restarted. They are used in the code to allow a state machine to be constructed, which mimics a set sequence of user interaction with the message boxes.
The rest is just string parsing of the MsgBox messages.