Sub GetCountriesFrom2Docs_AddToNewDoc()
    Dim doc_name1 As String: doc_name1 = "c:\scratch\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:\scratch\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:\scratch\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
    
    new_doc_rng.Text = "Countries from Doc1:" & vbCrLf
    new_doc_rng.Move wdParagraph
    For x = 1 To UBound(arr1)
        If arr1(x) <> "" Then
            new_doc_rng.Text = arr1(x) & vbCrLf
            new_doc_rng.Move wdParagraph
        End If
    Next x
    
    new_doc_rng.Text = vbCrLf & vbCrLf
    
    new_doc_rng.Text = "Countries from Doc2:" & vbCrLf
    new_doc_rng.Move wdParagraph
    For x = 1 To UBound(arr2)
        If arr2(x) <> "" Then
            new_doc_rng.Text = arr2(x) & vbCrLf
            new_doc_rng.Move wdParagraph
        End If
    Next x
    
    new_doc.SaveAs2 new_doc_name
End Sub