Highlight precedent cells with colour displayed in Msbox in the code

[shoun2502]

Dear all,

I have a vba code found in other forum.
It does what I want but instead I need to highlight precedent cells with some color despite displaying in the msg box.
The code below returns the Precedent cells in the message box.
I need to highlight all precedent cells with color despite getting the result in message box.

I look forward to having revert on the same and would appreciate any inputs in the sub routine

The code is as follows :

Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the active cell
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
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
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
[CODE=vba]

.

 

[Fluff]

If you want to highlight the cell & have the message try adding the line in blue

Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the active cell
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
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
ActiveCell.Interior.Color = 456789
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

 

[shoun2502]

T

If you want to highlight the cell & have the message try adding the line in blue

Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the active cell
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
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
ActiveCell.Interior.Color = 456789
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

Thanks a lot! It worked

 

[Fluff]

You're welcome & thanks for the feedback.