Sub ReplaceCellReferencesWithTheirValues()
Dim R As Long, C As Long, ShapeCount As Long, Arrow As Long, Link As Long
Dim Addr As String, OriginalSheet As String, OriginalCell As String, Frmla() As String
Dim Cell As Range, CurrentCell As Range, OriginalSelection As String
Application.ScreenUpdating = False
OriginalSheet = ActiveSheet.Name
OriginalCell = ActiveCell.Address
OriginalSelection = Selection.Address
ShapeCount = ActiveSheet.Shapes.Count
ReDim Frmla(1 To Selection.Rows.Count, 1 To Selection.Columns.Count)
For R = 1 To UBound(Frmla, 1)
For C = 1 To UBound(Frmla, 2)
Set CurrentCell = Range(OriginalSelection)(1).Offset(R - 1, C - 1)
Frmla(R, C) = 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(R, C) = Replace(Frmla(R, C), ActiveCell.Address(0, 0), ActiveCell.Value)
Frmla(R, C) = Replace(Frmla(R, C), ActiveCell.Parent.Name & "!", "")
Frmla(R, C) = Replace(Frmla(R, C), "'" & ActiveCell.Parent.Name & "'!", "")
Link = Link + 1
Continue:
Loop
Next
CurrentCell.ShowPrecedents Remove:=True
End If
Worksheets(OriginalSheet).Activate
Range(OriginalCell).Activate
Next
Next
Range(OriginalSelection).Formula = Frmla
Application.ScreenUpdating = False
End Sub