Sub CheckCellReferences()
Dim ShapeCount As Long, Arrow As Long, Link As Long, Addr As String, Frmla As String
Dim Cell As Range, CurrentCell As Range, OriginalSheet As String, OriginalCell As String
Application.ScreenUpdating = False
OriginalSheet = ActiveSheet.Name
OriginalCell = ActiveCell.Address
ShapeCount = ActiveSheet.Shapes.Count
For Each Cell In Selection
Set CurrentCell = Cell
Frmla = Replace(CurrentCell.Formula, "$", "")
If CurrentCell.HasFormula Then
CurrentCell.ShowPrecedents
Link = 1
For Arrow = 1 To ActiveSheet.Shapes.Count - ShapeCount
On Error Resume Next
Do
CurrentCell.Parent.Activate
CurrentCell.Activate
Addr = CurrentCell.NavigateArrow(True, Arrow, Link).Address
If Err.Number Then
Link = 1
Exit Do
End If
Frmla = Replace(Frmla, ActiveCell.Address(0, 0), ActiveCell.Value)
Frmla = Replace(Frmla, ActiveCell.Parent.Name & "!", "")
Frmla = Replace(Frmla, "'" & ActiveCell.Parent.Name & "'!", "")
Link = Link + 1
Continue:
Loop
Cell.Offset(, 1) = "'" & Frmla
Next
CurrentCell.ShowPrecedents Remove:=True
End If
Worksheets(OriginalSheet).Activate
Range(OriginalCell).Activate
Next
Application.ScreenUpdating = False
End Sub