JackkG
05-21-2015, 01:47 PM
Hi All,
I got a procedure which checks on precedents and dependents of a particular cell. Here is the complete code below. The results are displayed in Immediate window, instead I want the results in a new sheet added to the end of the sheet available. Can someone help me out with this.
Thanks!
Sub TestPrecedents()
Dim rngToCheck As Range
Dim dicAllPrecedents As Object
Dim i As Long
Set rngToCheck = ActiveCell
Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
Debug.Print "==="
If dicAllPrecedents.Count = 0 Then
Debug.Print rngToCheck.Address(external:=True); " has no precedent cells."
Else
For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
Debug.Print "[ Level:"; dicAllPrecedents.Items()(i); "]";
Debug.Print "[ Address: "; dicAllPrecedents.Keys()(i); " ]"
Next i
End If
Debug.Print "==="
End Sub
'won't navigate through precedents in closed workbooks
'won't navigate through precedents in protected worksheets
'won't identify precedents on hidden sheets
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As Object
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)
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)
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
I got a procedure which checks on precedents and dependents of a particular cell. Here is the complete code below. The results are displayed in Immediate window, instead I want the results in a new sheet added to the end of the sheet available. Can someone help me out with this.
Thanks!
Sub TestPrecedents()
Dim rngToCheck As Range
Dim dicAllPrecedents As Object
Dim i As Long
Set rngToCheck = ActiveCell
Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
Debug.Print "==="
If dicAllPrecedents.Count = 0 Then
Debug.Print rngToCheck.Address(external:=True); " has no precedent cells."
Else
For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
Debug.Print "[ Level:"; dicAllPrecedents.Items()(i); "]";
Debug.Print "[ Address: "; dicAllPrecedents.Keys()(i); " ]"
Next i
End If
Debug.Print "==="
End Sub
'won't navigate through precedents in closed workbooks
'won't navigate through precedents in protected worksheets
'won't identify precedents on hidden sheets
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As Object
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)
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)
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