View Single Post
 
Old 06-29-2018, 11:17 AM
XRope XRope is offline Windows 7 64bit Office 2010 32bit
Novice
 
Join Date: Jun 2018
Posts: 17
XRope is on a distinguished road
Default

The code is basicaly the same as what you gave me.
Its working fine, I get the 2 column with text in () except I dont get the countries included


here the code


Code:
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\Sanja\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
Reply With Quote