Sub EgyptReformatter()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, j As Long
Set FRDoc = Documents.Open("C:\Users\" & Environ("UserName") & "\Documents\Egypt List.txt", _
  ReadOnly:=True, Addtorecentfiles:=False, Visible:=False)
FRList = FRDoc.Range.Text
FRDoc.Close False: Set FRDoc = Nothing
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = True
  .MatchCase = True
  For j = 0 To UBound(Split(FRList, vbCr)) - 1
    If InStr(FRList, vbTab & vbTab) > 0 Then
      If Split(Split(FRList, vbCr)(j), vbTab)(6) > 0 Then
        .Text = Split(Split(FRList, vbCr)(j), vbTab)(0)
        .Replacement.Text = Split(Split(FRList, vbCr)(j), vbTab)(3)
        .Execute Replace:=wdReplaceAll
        DoEvents
      End If
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub

' ConvertTable Macro
Sub ConvertTable()
Dim StrOld As String, StrNew As String
Dim RngFind As Range, RngTxt As Range, i As Long
StrOld = "a,b,c"
StrNew = "α,β,γ"
Set RngTxt = Selection.Range
For i = 0 To UBound(Split(StrOld, ","))
  Set RngFind = RngTxt.Duplicate
  With RngFind.Find
         ' Clear all previously set formatting for Find dialog box.
         .ClearFormatting
         ' Set font to Find for replacement.
         .Font.Name = "bwgrkl"
         ' Clear all previously set formatting for Replace dialog box.
         .Replacement.ClearFormatting
         ' Set font to Replace found font.
         .Replacement.Font.Name = "Arial Unicode MS"
         ' Don't find or replace any text.
         .Text = Split(StrOld, ",")(i)
         .Replacement.Text = Split(StrNew, ",")(i)
         .Format = True
         .MatchCase = True
         .MatchWholeWord = False
         .MatchWildcards = False
         .MatchSoundsLike = False
         .MatchAllWordForms = False
         .Execute Replace:=wdReplaceAll
  End With
Next
End Sub