Private Type CountriesFoundInDoc
    Name As String
    Location As Long
End Type

Option Explicit

Private Type CountriesFoundInDoc
    Name As String
    Location As Long
End Type

Sub FindCountryNames()
    Dim d As Document: Set d = ActiveDocument
    Dim r As Range: Set r = d.Content
    
    Dim possible_countries() As String
    possible_countries = country_names
    
    Dim countries_found() As CountriesFoundInDoc
    ReDim countries_found(0 To 100)
    
    Dim x As Integer
    Dim y As Integer: y = 0

    For x = 1 To UBound(possible_countries)
        Set r = d.Content
        With r.Find
            .ClearFormatting
            .Text = possible_countries(x)
            .Execute
            Do While .Found
                countries_found(y).Name = r.Text
                countries_found(y).Location = r.Start
                .Execute
                y = y + 1
            Loop
        End With
    Next x
    
    ReDim Preserve countries_found(y - 1)

    QuickSort_CountryList countries_found, 0, UBound(countries_found)
    
    
    Set r = d.Content
    r.InsertBefore vbCrLf
    r.Move wdParagraph, -1
    For x = 1 To UBound(countries_found) - 1
        r.Text = countries_found(x - 1).Name & vbCrLf
        r.Move wdParagraph
    Next x

End Sub

Sub QuickSort_CountryList(vArray() As CountriesFoundInDoc, ByVal inLow As Long, ByVal inHi As Long)

  Dim pivot   As Variant
  Dim tmpSwap As CountriesFoundInDoc
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2).Location

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow).Location < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi).Location And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort_CountryList vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort_CountryList vArray, tmpLow, inHi

End Sub

Function country_names() As String()
    Dim arr(1 To 69) As String

    arr(1) = "Albania"
    arr(2) = "Andorra"
    arr(3) = "Armenia"
    arr(4) = "Australia"
    arr(5) = "Austria"
    arr(6) = "Azerbaijan"
    arr(7) = "Belarus"
    arr(8) = "Belgium"
    arr(9) = "Bosnia Herzegovina"
    arr(10) = "Bulgaria"
    arr(11) = "Canada"
    arr(12) = "Croatia"
    arr(13) = "Cyprus"
    arr(14) = "Czech Republic"
    arr(15) = "Denmark"
    arr(16) = "Egypt"
    arr(17) = "Estonia"
    arr(18) = "Finland"
    arr(19) = "France"
    arr(20) = "Georgia"
    arr(22) = "Germany"
    arr(23) = "Greece"
    arr(24) = "Hungary"
    arr(25) = "Iceland"
    arr(26) = "Iraq"
    arr(27) = "Ireland"
    arr(28) = "Israel"
    arr(29) = "Italy"
    arr(30) = "Japan"
    arr(31) = "Jordan"
    arr(32) = "Kazakhstan"
    arr(33) = "South Korea"
    arr(34) = "Kosovo"
    arr(35) = "Latvia"
    arr(36) = "Liechtenstein"
    arr(37) = "Lithuania"
    arr(38) = "Luxembourg"
    arr(39) = "Macedonia"
    arr(40) = "Malta"
    arr(41) = "Moldova"
    arr(42) = "Monaco"
    arr(43) = "Mongolia"
    arr(44) = "Montenegro"
    arr(45) = "Morocco"
    arr(46) = "Netherlands"
    arr(47) = "Norway"
    arr(48) = "Poland"
    arr(49) = "Portugal"
    arr(50) = "Romania"
    arr(51) = "Russian Federation"
    arr(52) = "San Marino"
    arr(53) = "Serbia"
    arr(54) = "Slovakia"
    arr(55) = "Slovenia"
    arr(56) = "Spain"
    arr(57) = "Sweden"
    arr(58) = "Switzerland"
    arr(59) = "Syria"
    arr(60) = "Taiwan"
    arr(61) = "Tajikistan"
    arr(62) = "Thailand"
    arr(63) = "Tunisia"
    arr(64) = "Turkey"
    arr(65) = "Turkmenistan"
    arr(66) = "Ukraine"
    arr(67) = "United Kingdom"
    arr(68) = "United States of America"
    arr(69) = "Uzbekistan"

    country_names = arr
End Function
Sub GetCountriesFrom2Docs_AddToNewDoc()
    Dim doc_name1 As String: doc_name1 = "C:\Users\Desktop\test\Doc1.docx"
    Dim doc1 As Document: Set doc1 = Documents.Open(doc_name1)
    Dim rng1 As Range: Set rng1 = doc1.Content
    Dim arr1(1 To 1000)
    
    Dim doc_name2 As String: doc_name2 = "C:\Users\Desktop\test\Doc2.docx"
    Dim doc2 As Document: Set doc2 = Documents.Open(doc_name2)
    Dim rng2 As Range: Set rng2 = doc2.Content
    Dim arr2(1 To 1000)

    Dim new_doc_name As String: new_doc_name = "C:\Users\Desktop\test\NewDoc.docx"
    Dim new_doc As Document: Set new_doc = Documents.Add
    Dim new_doc_rng As Range: Set new_doc_rng = new_doc.Content
    new_doc.SaveAs2 new_doc_name
    
    Dim x As Integer
    x = 1
    With rng1.Find
        .ClearFormatting
        .Forward = True
        .Text = "\(*\)"
        .MatchWildcards = True
        .Execute
        Do While .Found
            arr1(x) = Mid(rng1.Text, 2, Len(rng1.Text) - 2)
            x = x + 1
            .Execute
        Loop
    End With
    doc1.Close
    
    x = 1
    With rng2.Find
        .ClearFormatting
        .Forward = True
        .Text = "\(*\)"
        .MatchWildcards = True
        .Execute
        Do While .Found
            arr2(x) = Mid(rng2.Text, 2, Len(rng2.Text) - 2)
            x = x + 1
            .Execute
        Loop
    End With
    doc2.Close
    
    Dim tbl As Table
    Set tbl = new_doc_rng.Tables.Add(new_doc_rng, 2, 2)
    
    tbl.Cell(1, 1).Range.Text = "Countries from Doc1:"
    tbl.Cell(1, 2).Range.Text = "Countries from Doc2:"
    
    Dim countries1_as_string As String
    For x = 1 To UBound(arr1)
        If arr1(x) <> "" Then
            countries1_as_string = _
                countries1_as_string & arr1(x) & Chr(10)
        End If
    Next x
    tbl.Cell(2, 1).Range.Text = countries1_as_string
    
    Dim countries2_as_string As String
    For x = 1 To UBound(arr1)
        If arr1(x) <> "" Then
            countries2_as_string = _
                countries2_as_string & arr2(x) & Chr(10)
        End If
    Next x
    tbl.Cell(2, 2).Range.Text = countries2_as_string

    new_doc.SaveAs2 new_doc_name
End Sub

Edit/Delete Message