Sub AutoTranslation()
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdYellow
Dim DocSrc As Document, DocTgt As Document, Tbl As Table, r As Long
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the source document containing the Find/Replace Table"
  .AllowMultiSelect = False
  If .Show = -1 Then
    Set DocSrc = Documents.Open(.SelectedItems(1), ReadOnly:=True, AddToRecentFiles:=False)
  Else
    MsgBox "No source file selected. Exiting", vbExclamation
    Exit Sub
  End If
End With
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the target document to be updated"
  .AllowMultiSelect = False
  If .Show = -1 Then
    Set DocTgt = Documents.Open(.SelectedItems(1), ReadOnly:=False, AddToRecentFiles:=True)
  Else
    MsgBox "No target file selected. Exiting", vbExclamation
    DocSrc.Close SaveChanges:=False
    Set DocSrc = Nothing
    Exit Sub
  End If
End With
Set Tbl = DocSrc.Tables(1)
With DocTgt
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWholeWord = True
    .MatchCase = True
    'Process each word from the reference document's first table.
    For r = 2 To Tbl.Rows.Count
      .Text = Split(Tbl.Cell(r, 2).Range.Text, vbCr)(0)
      .Replacement.Text = Split(Tbl.Cell(r, 3).Range.Text, vbCr)(0)
      .Execute Replace:=wdReplaceAll
    Next
  End With
  .SaveAs2 FileName:=Split(.FullName, ".doc")(0) & ".rtf", Fileformat:=wdFormatRTF, AddToRecentFiles:=False
End With
DocSrc.Close SaveChanges:=False
Set Tbl = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Options.DefaultHighlightColorIndex = wdNoHighlight
Application.ScreenUpdating = True
MsgBox "Successfully replaced on the exactly matched strings"
End Sub