I need help to enhance my code...

[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

[Paul_Hossler]

Not tested, but something to start with

 
Sub TestPrecedents()
    Dim wsAllPrecedents As Worksheet
    Dim sAllPrecedents As String
    
    Dim rngToCheck As Range
    Dim dicAllPrecedents As Object
    Dim i As Long
     
    Set rngToCheck = ActiveCell
    Set dicAllPrecedents = GetAllPrecedents(rngToCheck)
     
    
    sAllPrecedents = rngToCheck.Parent.Name & "_Prec"
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sAllPrecedents).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsAllPrecedents = Worksheets.Add(, rngToCheck.Parent)
    wsAllPrecedents.Name = sAllPrecedents
    
    
    If dicAllPrecedents.Count = 0 Then
        MsgBox rngToCheck.Address(1, 1, 1, 1) & " has no precedent cells."
    Else
        For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
            wsAllPrecedents.Cells(i, 1).Value = "[ Level: " & dicAllPrecedents.Items()(i) & " ]"
            wsAllPrecedents.Cells(i, 2).Value = "[ Address: " & dicAllPrecedents.Keys()(i) & " ]"
        Next I
    End If
     
End Sub

[JackkG]

Hi Paul,

Thanks for the code help. It works great!!! with little modification. Do you have any idea, how we can get the same code to check for cell Dependents, if yes, how to modify the code. Can you help me on this?

Thanks!

[Paul_Hossler]

I'd start by copying the two GetPrecedents and GetCellPrecedents and making them work for Dependents.

The loop code is similar

I'm not familiar with dependents and precedents using VBA but you look like you have a handle on it

[JackkG]

Yep..not having a good handle on it but got it solved. Thanks for your help on this one. Really appreciate it!!!

[JackkG]

Hi Paul,

sorry to bug you on this one. You helped me adding the list of precedents and dependents on a new sheet added. Can you be able to help me out with the same in Listbox or List view or something similar. I tried it out but not able to get it.

Thanks!

[Paul_Hossler]

be glad to try

Listbox on userform or worksheet?

2 columns? Cell and then precedient?

[JackkG]

Listbox on user form. 2 columns will do, I mean any way you can. Thanks!

[JackkG]

Hi Paul,

Any progress on the above query??

[Paul_Hossler]

http://www.vbaexpress.com/forum/show...de-enhancement

[SamT]

I am closing this thread. For further reading see Can someone help on my code enhancement