Draw precedent arrows for formulas in a range

[ganeshr]

Hello there. So far i 've coded for trace precedents in Excel VBA.consider i have 3 formulas in a worksheet. what i need is to select the three formulas in a range and to draw precedent arrows at a time. i have a code that draws arrows for a single formula. suggest me the code that selects all formulas in a range and to apply trace precedents. Thanks in advance.

[Kenneth Hobs]

Sub t()
Dim cell As Range
For Each cell In Range("A1:B2").Precedents
cell.DirectDependents.ShowPrecedents
Next cell
End Sub

[Aflatoon]

For example:


Dim rgFormulas As Excel.Range
Dim rgCell As Excel.Range
Set rgFormulas = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
For Each rgCell In rgFormulas
rgCell.ShowPrecedents
Next rgCell

[ganeshr]

Thanks sir. The code you suggested works well for precedents that are inbuilt in Excel. but i have coded to find precedents and to draw arrows manually. This is the code for that. And this works only for the active cell. I need to select all the formulas in a range to draw precedent arrows manually. Here is the code. Hope you help me.



Sub FindPrecedents()
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
Call GetFormula(rLast)
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
s = Selection.Address
Call Arrow(rLast, rLast.Worksheet.Range(s))
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub

Sub Arrow(rnStart As Range, rnEnd As Range)
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddLine(MOC(rnStart), MOC(rnStart, True), MOC(rnEnd), MOC(rnEnd, True)).Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(Red:=0, Green:=0, Blue:=280)
.BackColor.RGB = RGB(0, 0, 128)
End With
End Sub

'MiddleOfCell: returns just that. Needed by the Arrow procedure
Function MOC(R As Range, Optional Y As Boolean) As Long
If Y Then
MOC = R.Top + R.Height / 2
Else
MOC = R.Left + R.Width / 2
End If
End Function

[Aflatoon]

I believe it would be:


Sub DrawAllPrecedents()
Dim rgFormulas As Excel.Range
Dim rgCell As Excel.Range
Set rgFormulas = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
For Each rgCell In rgFormulas
FindPrecedents rgCell
Next rgCell
End Sub

Sub FindPrecedents(rLast As Excel.Range)
Dim iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
rLast.ShowPrecedents
Call GetFormula(rLast)
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
s = Selection.Address
Call Arrow(rLast, rLast.Worksheet.Range(s))
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub

Sub Arrow(rnStart As Range, rnEnd As Range)
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddLine(MOC(rnStart), MOC(rnStart, True), MOC(rnEnd), MOC(rnEnd, True)).Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(Red:=0, Green:=0, Blue:=280)
.BackColor.RGB = RGB(0, 0, 128)
End With
End Sub

'MiddleOfCell: returns just that. Needed by the Arrow procedure
Function MOC(R As Range, Optional Y As Boolean) As Long
If Y Then
MOC = R.Top + R.Height / 2
Else
MOC = R.Left + R.Width / 2
End If
End Function

[ganeshr]

Thank you very much sir..It works very well.. :thumb