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