Can someone modify code for me.

Hi All,

I have code for tracing cell precedents and dependents and list the same in a new worksheet. But i want someone to modify the code such that instead of worksheet, it should list all the cell precedents and dependents in a listbox or list view on user form or listbox or list view on a worksheet.

It will be a great help if someone can modify the code for me.

Here is the code for precedents and dependents.

--------Code for precedents

'trace precedents

Option Explicit
Sub TestPrecedents()
    Dim wsAllPrecedents As Worksheet
    Dim sAllPrecedents As String
    
    Dim cel As Range, rng As Range
    Set rng = Selection
     
    Dim rngToCheck As Range
    Dim dicAllPrecedents As Object
    Dim i As Long
    Dim ReportRow   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)
    Set wsAllPrecedents = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    
    wsAllPrecedents.Name = sAllPrecedents
     
    If dicAllPrecedents.Count = 0 Then
        MsgBox rngToCheck.Address(1, 1, 1, 1) & " has no precedent cells."
    Else
            For Each cel In rngToCheck
                    cel.ShowPrecedents
            Next cel
        For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)

        ReportRow = ReportRow + 1
            wsAllPrecedents.Cells(ReportRow, 1).Value = "[ Level:" & dicAllPrecedents.Items()(i) & "] " & _
            "[ Address: " & dicAllPrecedents.Keys()(i) & " ]"
        Next i
    End If
End Sub

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

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

----------------------------------------------
----Code for dependents

'Trace Dependents

Sub ListDependents()
Dim cel As Range, rng As Range
Set rng = Selection
     
Dim rngToCheck As Range
Set rngToCheck = ActiveCell
    
Dim wks As Worksheet
Dim rngFormulas As Range, rngCell As Range
Dim objDict As Object
Dim varDeps As Variant, varItem As Variant
Dim lngRow As Long, x As Long, y As Long
Dim wksOut As Worksheet

ThisWorkbook.Application.Run "Unsecure"
Application.ScreenUpdating = False
Set rngFormulas = Selection

'this Dictionary will hold the addresses
Set objDict = CreateObject("Scripting.Dictionary")

If Not rngFormulas Is Nothing Then
For Each cel In rngToCheck
    cel.ShowDependents
Next cel
For Each rngCell In rngFormulas
ListCellDependents rngCell, objDict
Next rngCell
Set rngFormulas = Nothing
End If

'Add sheet

sAllPrecedents = rngToCheck.Parent.Name & "_Depend"
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(sAllPrecedents).Delete
Application.DisplayAlerts = True
On Error GoTo 0

'Set wksOut = Worksheets.Add
Set wksOut = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wksOut.Name = sAllPrecedents
    

wksOut.Range("A1:B1").Value = Array("Original Cell", "Dependents")
lngRow = 2

For Each varItem In objDict.Keys
varDeps = Split(objDict.Item(varItem), "|")

For y = LBound(varDeps) To UBound(varDeps)
wksOut.Cells(lngRow, "A").Value = varItem
wksOut.Cells(lngRow, "B").Value = varDeps(y)
lngRow = lngRow + 1
Next y

Next varItem

Application.ScreenUpdating = True
ThisWorkbook.Application.Run "Secure"
End Sub



Sub ListCellDependents(rngCheck As Range, dict As Object)

Dim lngSheetCounter As Long, lngRefCounter As Long
Dim strKey As String, strAddy As String

strKey = "'" & rngCheck.Parent.Name & "'!" & rngCheck.Address(0, 0)
lngSheetCounter = 1

On Error Resume Next
With rngCheck
.ShowDependents False
Do
lngRefCounter = 1
Do
.NavigateArrow False, lngSheetCounter, lngRefCounter
strAddy = "'" & Selection.Parent.Name & "'!" & Selection.Address(0, 0)

If Err.Number = 0 Then
If strAddy = strKey Then

rngCheck.ShowDependents True

Exit Sub
Else

If dict.Exists(strKey) Then
dict(strKey) = dict(strKey) & "|" & strAddy

Else

dict(strKey) = strAddy

End If
End If

lngRefCounter = lngRefCounter + 1

Else
Err.Clear
Exit Do

End If

Loop

lngSheetCounter = lngSheetCounter + 1

Loop

End With

End Sub