Draw precedent arrows for formulas in a range

[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