Sub ChangeFileLinks()
    Dim f As Object
    Dim i, x, fieldCount As Long
    Dim iRet As Integer
    Dim Message As String
    Dim OldPath As String
    Dim OldFile As String
    Dim NewPath, WPPath As String
    Dim NewFile As String
    Dim sFind As String
    Dim SReplace As String
    Dim ofld As Field
    
    On Error GoTo LinkError
        
    iRet = MsgBox("Link Report to New Excel File?", vbYesNo)
    If iRet = vbNo Then Exit Sub
    
    Set f = Application.FileDialog(3)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only

    If f.Show Then
        For i = 1 To f.SelectedItems.Count
            'Get the File Path Only
            NewPath = f.InitialFileName
            WPPath = f.InitialFileName
            NewPath = Replace(NewPath, "\", "\\")
            
            'Get the FileName only.  Uses Public FileName Function Below
            NewFile = FileName(f.SelectedItems(i))
            'MsgBox "The New File Path is: " & NewPath
            'MsgBox "The FileName Only is: " & Filename(f.SelectedItems(i))
            
        Next
    Else 'user clicked cancel
        Exit Sub
    End If
    
    'Confirm User wishes to change the file
    Message = "Please confirm you would like to link this report to the following file:" & vbNewLine & vbNewLine
    Message = Message & f.InitialFileName & NewFile & vbNewLine & vbNewLine
    Message = Message & "Are you sure you would like to continue?"
    iRet = MsgBox(Message, vbYesNo)
    If iRet = vbNo Then Exit Sub
    
    Call MsgBox("Please allow approximately 1 minute to link all charts", vbOKOnly)
    
    With ActiveDocument
        'First Fix FilePath in case file was emailed
        ActiveWindow.View.ShowFieldCodes = True  'Field Code On
        For Each ofld In ActiveDocument.Fields
        If ofld.Type = wdFieldLink Then
            If InStr(1, ofld.Code, ".xlsm!") > 0 Then
                sFind = ".xlsm!"
                SReplace = ".xlsm"" """
                Call FindAndReplace(sFind, SReplace)
                sFind = """"" \p"
                SReplace = "\p"
                Call FindAndReplace(sFind, SReplace)
                Exit For
            End If
        End If
        Next ofld
        ActiveWindow.View.ShowFieldCodes = False  'Field Code Off

        fieldCount = .Fields.Count
        For x = 1 To fieldCount
            With .Fields(x)
                'Debug.Print .Type
                If .Type = 56 Then
                    'Get The Existing FilePath and File Name from the Link Sources
                    OldPath = .LinkFormat.SourcePath & "\"
                    OldPath = Replace(OldPath, "\", "\\")
                    'MsgBox "The Existing FilePath is: " & OldPath
                    
                    OldFile = .LinkFormat.SourceName
                    'MsgBox "The Existing File Name is: " & .LinkFormat.SourceName
                    
                    'Replace the FilePath
                    ' Replace the link to the external file
                    .Code.Text = Replace(.Code.Text, OldPath, NewPath)
                    '.LinkFormat.SourceFullName = NewPath
                    
                    'Replace the ExtraFileName for the Graphs only
                    '.LinkFormat.SourceName = NewFile
                    .Code.Text = Replace(.Code.Text, OldFile, NewFile)
                    '.Update
                    
                End If
            End With
        Next x
        .Fields.Update       
    End With
    
    Call MsgBox("All Links Succesfully Updated!", vbOKOnly)
    
Exit Sub

LinkError:
Select Case Err.Number
  Case 5391 'could not find associated Range Name
    MsgBox "Could not find the associated Excel Range Name " & _
      "for one or more links in this document. " & _
      "Please be sure that you have selected a valid " & _
      "workpaper file.", vbCritical
  Case Else
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
End Select
End Sub

Public Function FileName(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        FileName = FileName(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

Sub FindAndReplace(sFind As String, SReplace As String)
  Dim rngStory As Range
  For Each rngStory In ActiveDocument.StoryRanges
    With rngStory.Find
      .Text = sFind
      .Replacement.Text = SReplace
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
    End With
  Next rngStory
End Sub