I need enhancement on my code...help needed

[JackkG]

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

cross-posted here:
I need help to enhance my code...