PDA

View Full Version : I need help to enhance my code...



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

Paul_Hossler
05-21-2015, 09:28 PM
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
05-22-2015, 08:47 AM
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
05-22-2015, 05:46 PM
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
05-25-2015, 07:00 AM
Yep..not having a good handle on it but got it solved. Thanks for your help on this one. Really appreciate it!!!

JackkG
05-26-2015, 02:54 PM
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
05-26-2015, 05:53 PM
be glad to try

Listbox on userform or worksheet?

2 columns? Cell and then precedient?

JackkG
05-27-2015, 09:48 AM
Listbox on user form. 2 columns will do, I mean any way you can. Thanks! :)

JackkG
05-29-2015, 06:06 AM
Hi Paul,

Any progress on the above query??

Paul_Hossler
05-29-2015, 12:47 PM
http://www.vbaexpress.com/forum/showthread.php?52746-Can-someone-help-on-my-code-enhancement

SamT
05-29-2015, 02:04 PM
I am closing this thread. For further reading see Can someone help on my code enhancement (http://www.vbaexpress.com/forum/showthread.php?52746-Can-someone-help-on-my-code-enhancement)