Draw precedent arrows for formulas in a range

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.

Code:

---

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

---

For example:

Code:

---

  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

---

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.

Code:

---

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

---

I believe it would be:

Code:

---

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

---

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