The following code traces back all precedents (or only current precedents, depending on whether you select the Boolean to be True or False) for a cell selected by the user. I am running the output to a new sheet called "Precedents", and currently only two columns are populated with the "Worksheet" and "Cell" precedent values. I have a need to add two more columns in this output to define the "Target Worksheet" and "Target Cell".
I am struggling to understand how to offset the Activecell (code is in the last few lines of the ZoomToPrecedents Sub) so that I can create two new columns and basically just store the cell name and worksheet name of the "target" cell (for example, "target" cell is the one the user picks to trace its precedents). The current output is displaying the "source" cells (precedents of target cell which are contained within the formula of the target cell). These four columns of source worksheet, source cell, target worksheet, and target cell will help me see which source cells are being used to create the target cell. Please let me know if you can help me to create this. I really appreciate it. Thanks.
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
