Sub Tabulate()
Application.ScreenUpdating = False
Dim Tbl As Table, StrCountries As String, RngSrc As Range, RngDest As Range
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = " ("
    .Replacement.Text = "^t("
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchKashida = False
    .MatchDiacritics = False
    .MatchAlefHamza = False
    .MatchControl = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
  Set Tbl = .ConvertToTable(Separator:=wdSeparateByTabs, _
    NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With Tbl
    j = .Rows.Count: m = 0
    For i = 1 To j
      Set RngSrc = .Rows(i).Cells(2).Range
      RngSrc.MoveEnd wdCharacter, -1
      If InStr(StrCountries, RngSrc.Text) = 0 Then
        StrCountries = StrCountries & "|" & RngSrc.Text
        .Rows.Add
        k = k + 1
        .Rows(j + k).Cells(1).Range.Text = RngSrc.Text
        .Rows(j + k).Cells(2).Range.Text = "1"
      Else
        l = UBound(Split(Split(StrCountries, RngSrc.Text)(0), "|")) + m
        Set RngDest = .Rows(j + l).Cells(2).Range
        RngDest.MoveEnd wdCharacter, -1
        RngDest.Text = CStr(CLng(RngDest.Text) + 1)
      End If
      .Rows(i).Cells.Merge
    Next
    StrCountries = "": m = k: n = k
    For i = 1 To j
      Set RngSrc = .Rows(i).Cells(1).Range
      RngSrc.MoveEnd wdCharacter, -1
      RngSrc.Text = Replace(RngSrc.Text, vbCr, " ")
      If InStr(StrCountries, RngSrc.Text) = 0 Then
        StrCountries = StrCountries & "|" & RngSrc.Text
        .Rows.Add
        k = k + 1
        .Rows(j + k).Cells(1).Range.Text = RngSrc.Text
        .Rows(j + k).Cells(2).Range.Text = "1"
      Else
        l = UBound(Split(Split(StrCountries, RngSrc.Text)(0), "|")) + m
        Set RngDest = .Rows(j + l).Cells(2).Range
        RngDest.MoveEnd wdCharacter, -1
        RngDest.Text = CStr(CLng(RngDest.Text) + 1)
      End If
    Next
    .Split j + 1
    .ConvertToText Separator:=vbCr
  End With
  .Tables(1).Split n + 1
End With
Set RngSrc = Nothing: Set RngDest = Nothing
Application.ScreenUpdating = True
End Sub