PDA

View Full Version : Can someone help on my code enhancement



JackkG
05-29-2015, 06:38 AM
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


------------------

Cross-posted here:
http://www.excelforum.com/showthread.php?t=1085443&p=4087072#post4087072

Paul_Hossler
05-29-2015, 07:38 AM
Userform is a little crude, and only Dependents works

Play with this and see

JackkG
05-29-2015, 01:14 PM
Thanks Paul!! I'll check out the attachment and will get back soon. Thanks a lot for your help!

stanleydgrom
05-31-2015, 01:02 PM
Cross posted here:

http://www.mrexcel.com/forum/excel-questions/858018-want-someone-enhance-my-code.html#post4171654

And, here:

http://www.excelforum.com/showthread...72#post4087072 (http://www.excelforum.com/showthread.php?t=1085443&p=4087072#post4087072)


A message to forum cross posters.

Please read this:

http://www.excelguru.ca/node/7

JackkG
06-03-2015, 10:43 AM
Hi Paul,

I tried to get Precedents on user form, but don't know how to tweak the code. Do you have any idea? Your trick on dependents works great.

JackkG
06-03-2015, 10:58 AM
or maybe another way. When we click on Precedents button, a new sheet is created listing cell precedents, maybe we can get the cell values in Listbox of user form. Any idea how to get this?

JackkG
06-03-2015, 12:07 PM
Hi Paul,

I almost got there. Just stuck on this one.

Normally we can get it like:


ufArrows.lbPrecedents.RowSource = "Sheet1!A1:A3"
ufArrows.Show

This show the content of sheet1 cell range A1 to A3 in listbox. But when I'm adding a new sheet with a name like:



sAllPrecedents = rngToCheck.Parent.Name & "_Prec"
Set wsAllPrecedents = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Coun t))
wsAllPrecedents.Name = sAllPrecedents


So how to get the same with this. for example:



ufArrows.lbPrecedents.RowSource = sAllPrecedents!A1:A3


[This is where I'm stuck, i mean how to get the sAllPrecedents name instead of sheet name, cause parent sheet name can be any name]