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

Option Explicit
Sub ProcessTable()
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlRange As Object
Dim oTable As Table
Dim oRng As Range
Dim oDoc As Document
Dim fDialog As FileDialog
Dim strWorkbookname As String
'Check document is valid
If ActiveDocument.Tables.Count = 0 Then GoTo err_handler
If ActiveDocument.Tables(1).Rows.Count < 31 Then GoTo err_handler
If ActiveDocument.Tables(1).Columns.Count < 2 Then GoTo err_handler
'Select the workbook
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = "Select the workbook to process"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel Workbooks", "*.xls* "
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , _
                   "List Folder Contents"
            Exit Sub
        End If
        strWorkbookname = .SelectedItems(1)
    End With
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo lbl_Exit
    'Open the workbook and set the required range
    Set xlBook = xlApp.Workbooks.Open(Filename:=strWorkbookname)
    Set xlSheet = xlBook.Sheets("Internal")
    Set xlRange = xlSheet.Range("A7:B31")
    'Copy the range
    xlRange.Copy
    'Close the workbook
    xlBook.Close SaveChanges:=False
    'Set the document to process and the table range
    Set oDoc = ActiveDocument
    Set oTable = oDoc.Tables(1)
    Set oRng = oDoc.Range(Start:=oTable.Cell(7, 1).Range.Start, _
                          End:=oTable.Cell(31, 2).Range.End)
    'Paste and format the data in the table
    With oRng
        .Paste
        .Font.name = "Trebuchet MS"
        .Font.Size = 10
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
    End With
    'CleanUp
lbl_Exit:
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlRange = Nothing
    Set oDoc = Nothing
    Set oTable = Nothing
    Set oRng = Nothing
    Exit Sub
err_handler:
    MsgBox "The activedocument does not appear to be the correct document?"
    GoTo lbl_Exit
End Sub