以下代码追溯用户选择的单元格中的所有先例（或仅当前先例，具体取决于您是选择布尔值为True还是False）。我正在将输出运行到名为＆＃34; Precedents＆＃34;的新工作表中，目前只有两列填充了＆＃34;工作表＆＃34;和＆＃34; Cell＆＃34;先例值。我需要在此输出中添加两个列来定义＆＃34;目标工作表＆＃34;和＆＃34;目标细胞＆＃34;。
我很难理解如何抵消Activecell（代码在ZoomToPrecedents Sub的最后几行），这样我就可以创建两个新列，基本上只存储＆＃34;的单元名称和工作表名称。目标＆＃34;单元格（例如，＆＃34; target＆＃34;单元格是用户选择跟踪其先例的单元格）。当前输出显示＆＃34; source＆＃34;细胞（靶细胞的先例，它包含在靶细胞的公式中）。这四列源工作表，源单元，目标工作表和目标单元格将帮助我查看正在使用哪些源单元格来创建目标单元格。如果你能帮助我创建这个，请告诉我。对此，我真的非常感激。感谢。
Sub ZoomToPrecedents()
' based off of https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
' accessed 8/11/15
Dim boolAllLevels As Boolean
' if you'd like to show all levels of dependency (this cell depends on this cell which depends on this cell which depends on this cell)
' set boolAllLevels to True
' I wouldn't recommend showing all levels of dependency for complex models - the message box will get really long
'
' if you'd like to only show the current cell's dependencies
' set boolAllLevels to False
' by default boolAllLevels will be set to False
boolAllLevels = False
Dim rngToCheck As Range
Dim dicAllPrecedents As Object
Dim i As Long
Dim strNoPrecedentsMsg As String
Dim strPrecedentsListMsg As String
Dim iGoToPrecedent As Integer
Dim strGoToPrecedent As String
Dim strGoToWorksheet As String
Dim strGoToRange As String
Dim iExclamPosition As Integer
Dim iBracketPosition As Integer
Dim j As Long
Dim k As Long
Dim strWorkbookFileName As String
Dim strWorksheetName As String
Dim strGoToWorkbook As String
Set rngToCheck = ActiveCell
Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
strWorkbookFileName = ActiveWorkbook.Name
strWorksheetName = ActiveSheet.Name
If dicAllPrecedents.Count = 0 Then
strToCheckNoPrecedents = rngToCheck.Address(External:=True) & " has no precedent cells."
MsgBox strPrecedentsListMsg, vbOKOnly, "No Precedents"
Else
For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
If dicAllPrecedents.Items()(i) = 1 Or boolAllLevels Then
strGoToPrecedent = dicAllPrecedents.Keys()(i)
If Not InStr(1, strGoToPrecedent, strWorkbookFileName, vbTextCompare) = 0 Then
iBracketPosition = InStr(1, strGoToPrecedent, "]", vbTextCompare)
iGoToPrecedentLength = Len(strGoToPrecedent)
j = iGoToPrecedentLength - iBracketPosition
strGoToPrecedent = Right(strGoToPrecedent, j)
strGoToPrecedent = "'" & strGoToPrecedent
If Not InStr(1, strGoToPrecedent, strWorksheetName, vbTextCompare) = 0 Then
iExclamationPosition = InStr(1, strGoToPrecedent, "!", vbTextCompare)
iGoToPrecedentLength = Len(strGoToPrecedent)
j = iGoToPrecedentLength - iExclamationPosition
strGoToPrecedent = Right(strGoToPrecedent, j)
End If
End If
strPrecedentsListMsg = strPrecedentsListMsg & i & ": "
If boolAllLevels Then
strPrecedentsListMsg = strPrecedentsListMsg & "(Level " & dicAllPrecedents.Items()(i) & ") "
End If
strPrecedentsListMsg = strPrecedentsListMsg & strGoToPrecedent & Chr(10)
End If
Next i
' 9/5/2017 additions ***************************************************************
'
'
' Add new worksheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Precedents"
' Add column headers
Sheets("Precedents").Activate
Range("A1").Value = "Worksheet"
Range("B1").Value = "Cell"
Range("C1").Value = "Target Worksheet"
Range("D1").Value = "Target Cell"
' Write precedents list
Dim strCurPrecedent As String
Dim iCurPrecedentLength As Integer
Dim iCurRange As Range
Dim strCurWorksheet As String
Dim strTargetWorksheet As String
Dim strTargetCell As Range
Range("A2").Activate
For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
If dicAllPrecedents.Items()(i) = 1 Or boolAllLevels Then
strCurPrecedent = dicAllPrecedents.Keys()(i)
iExclamationPosition = InStr(1, strCurPrecedent, "!", vbTextCompare)
iBracketPosition = InStr(1, strCurPrecedent, "]", vbTextCompare)
iCurPrecedentLength = Len(strCurPrecedent)
j = iBracketPosition - 3
strCurWorkbook = Mid(strCurPrecedent, 3, j)
j = iCurPrecedentLength - iExclamationPosition
strCurRange = Right(strCurPrecedent, j)
j = iBracketPosition + 1
k = iExclamationPosition - j - 1
strCurWorksheet = Mid(strCurPrecedent, j, k)
ActiveCell.Value = strCurWorksheet
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = strCurRange
ActiveCell.Offset(1, -1).Activate\
End If
Next I
***************************************************************
' 9/5/2017 removals ***************************************************************
'
'
' iGoToPrecedent = InputBox(strPrecedentsListMsg, "Go To Precedent", "Enter line number from above")
' strGoToPrecedent = dicAllPrecedents.Keys()(iGoToPrecedent)
'
' iExclamationPosition = InStr(1, strGoToPrecedent, "!", vbTextCompare)
' iBracketPosition = InStr(1, strGoToPrecedent, "]", vbTextCompare)
' iGoToPrecedentLength = Len(strGoToPrecedent)
'
' j = iBracketPosition - 3
' strGoToWorkbook = Mid(strGoToPrecedent, 3, j)
'
' j = iGoToPrecedentLength - iExclamationPosition
' strGoToRange = Right(strGoToPrecedent, j)
'
' j = iBracketPosition + 1
' k = iExclamationPosition - j - 1
' strGoToWorksheet = Mid(strGoToPrecedent, j, k)
'
' Application.GoTo Reference:=Workbooks(strGoToWorkbook).Worksheets(strGoToWorksheet).Range(strGoToRange)
' End of 9/5/2017 removals ***************************************************************
End If
End Sub
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As Object
' courtesy of https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
' accessed 8/11/15
' won't navigate through precedents in closed workbooks
' won't navigate through precedents in protected worksheets
' won't identify precedents on hidden sheets
Const lngTOP_LEVEL As Long = 1
Dim dicAllPrecedents As Object
Dim strKey As String
Set dicAllPrecedents = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
GetPrecedents rngToCheck, dicAllPrecedents, lngTOP_LEVEL
Set GetAllPrecedents = dicAllPrecedents
Application.ScreenUpdating = True
End Function
Private Sub GetPrecedents(ByRef rngToCheck As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
' courtesy of https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
' accessed 8/11/15
Dim rngCell As Range
Dim rngFormulas As Range
If Not rngToCheck.Worksheet.ProtectContents Then
If rngToCheck.Cells.CountLarge > 1 Then 'Change to .Count in XL 2003 or earlier
On Error Resume Next
Set rngFormulas = rngToCheck.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Else
If rngToCheck.HasFormula Then Set rngFormulas = rngToCheck
End If
'
If Not rngFormulas Is Nothing Then
For Each rngCell In rngFormulas.Cells
GetCellPrecedents rngCell, dicAllPrecedents, lngLevel
Next rngCell
rngFormulas.Worksheet.ClearArrows
End If
End If
End Sub
Private Sub GetCellPrecedents(ByRef rngCell As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)
' courtesy of https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
' accessed 8/11/15
Dim lngArrow As Long
Dim lngLink As Long
Dim blnNewArrow As Boolean
Dim strPrecedentAddress As String
Dim rngPrecedentRange As Range
Do
lngArrow = lngArrow + 1
blnNewArrow = True
lngLink = 0
Do
lngLink = lngLink + 1
rngCell.ShowPrecedents
On Error Resume Next
Set rngPrecedentRange = rngCell.NavigateArrow(True, lngArrow, lngLink)
If Err.Number <> 0 Then
Exit Do
End If
On Error GoTo 0
strPrecedentAddress = rngPrecedentRange.Address(False, False, xlA1, True)
If strPrecedentAddress = rngCell.Address(False, False, xlA1, True) Then
Exit Do
Else
blnNewArrow = False
If Not dicAllPrecedents.Exists(strPrecedentAddress) Then
dicAllPrecedents.Add strPrecedentAddress, lngLevel
GetPrecedents rngPrecedentRange, dicAllPrecedents, lngLevel + 1
End If
End If
Loop
If blnNewArrow Then Exit Do
Loop
End Sub
答案 0 :(得分：0)
VBA: Determine All Precedent Cells – A Nice Example Of Recursion
我使用MichaelMøldrup对Find all used references in Excel formula的回答来提取公式而不使用ShowPrecedents。
Level Workbook Worksheet Cell.Address Formula Value
0 Precedents.xlsm Sheet1 $A$1 =INDIRECT("B1") 1
0 Precedents.xlsm Sheet1 $A$2 =SUM(B2,Sheet2!A2) 8
1 Precedents.xlsm Sheet2 $A$2 =SUM(B2,Sheet3!A2) 6
2 Precedents.xlsm Sheet3 $A$2 =SUM(B2:C2) 4
0 Precedents.xlsm Sheet1 $A$3 =SUM(B3,Sheet2!A3) 12
1 Precedents.xlsm Sheet2 $A$3 =SUM(B3,Sheet3!A3) 9
2 Precedents.xlsm Sheet3 $A$3 =SUM(B3:C3) 6
0 Precedents.xlsm Sheet1 $A$4 =SUM(B4,Sheet2!A4) 16
1 Precedents.xlsm Sheet2 $A$4 =SUM(B4,Sheet3!A4) 12
2 Precedents.xlsm Sheet3 $A$4 =SUM(B4:C4) 8
0 Precedents.xlsm Sheet1 $A$5 =SUM(B5,Sheet2!A5) 20
1 Precedents.xlsm Sheet2 $A$5 =SUM(B5,Sheet3!A5) 15
2 Precedents.xlsm Sheet3 $A$5 =SUM(B5:C5) 10
0 Precedents.xlsm Sheet1 $A$6 =SUM(B6,Sheet2!A6) 24
1 Precedents.xlsm Sheet2 $A$6 =SUM(B6,Sheet3!A6) 18
2 Precedents.xlsm Sheet3 $A$6 =SUM(B6:C6) 12
0 Precedents.xlsm Sheet1 $A$7 =SUM(B7,Sheet2!A7) 28
1 Precedents.xlsm Sheet2 $A$7 =SUM(B7,Sheet3!A7) 21
2 Precedents.xlsm Sheet3 $A$7 =SUM(B7:C7) 14
0 Precedents.xlsm Sheet1 $A$8 =SUM(B8,Sheet2!A8) 32
1 Precedents.xlsm Sheet2 $A$8 =SUM(B8,Sheet3!A8) 24
2 Precedents.xlsm Sheet3 $A$8 =SUM(B8:C8) 16
0 Precedents.xlsm Sheet1 $A$9 =SUM(B9,Sheet2!A9) 36
1 Precedents.xlsm Sheet2 $A$9 =SUM(B9,Sheet3!A9) 27
2 Precedents.xlsm Sheet3 $A$9 =SUM(B9:C9) 18
0 Precedents.xlsm Sheet1 $A$10 =SUM(B10,Sheet2!A10) 40
1 Precedents.xlsm Sheet2 $A$10 =SUM(B10,Sheet3!A10) 30
2 Precedents.xlsm Sheet3 $A$10 =SUM(B10:C10) 20
代码：
Sub Test_ListPrecedents()
Dim result As Variant
Dim Target As Range
With ThisWorkbook.Worksheets("Sheet1")
Set Target = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
result = getPrecedentsInfo(Target)
If IsMissing(result) Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Precedents").Delete
Application.DisplayAlerts = True
On Error GoTo 0
With ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
.Name = "Precedents"
.Range("A1").Resize(UBound(result), UBound(result, 2)).Value = result
.Columns.AutoFit
End With
End Sub
Function getPrecedentsInfo(Target As Range) As Variant
Dim x As Long
Dim result As Variant
Dim PrecedentsList As Object
Set PrecedentsList = CreateObject("System.Collections.Arraylist")
FillPrecedentsList Target, PrecedentsList
If PrecedentsList.Count > 0 Then
PrecedentsList.Insert 0, Array("Level", "Workbook", "Worksheet", "Cell.Address", "Formula", "Value")
result = PrecedentsList.ToArray
result = Application.Transpose(result)
result = Application.Transpose(result)
getPrecedentsInfo = result
End If
End Function
Sub FillPrecedentsList(Target As Range, Optional PrecedentsList As Object, Optional objRegEx As Object, Optional Level As Long)
Dim cell As Range
Dim testExpression As String
If objRegEx Is Nothing Then
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.Global = True
End If
For Each cell In Target
objRegEx.Pattern = """.*?""" ' remove expressions
If cell.HasFormula Then
testExpression = CStr(cell.Formula)
testExpression = objRegEx.Replace(testExpression, "")
objRegEx.Pattern = "(([A-Z])+(\d)+)" 'grab the address
objRegEx.Pattern = "(['].*?['!])?([[A-Z0-9_]+[!])?(\$?[A-Z]+\$?(\d)+(:\$?[A-Z]+\$?(\d)+)?|\$?[A-Z]+:\$?[A-Z]+|(\$?[A-Z]+\$?(\d)+))"
PrecedentsList.Add Array(Level, cell.Parent.Parent.Name, cell.Parent.Name, cell.Address, "'" & cell.Formula, cell.Value)
Else
Exit Sub
End If
If objRegEx.Test(testExpression) Then
Set result = objRegEx.Execute(testExpression)
If result.Count > 0 Then
For Each Match In result
FillPrecedentsList Range(Match.Value), PrecedentsList, objRegEx, Level + 1
Next Match
End If
End If
Next
End Sub