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