Extract List of terms and combine on a Table

[XRope]

Hi everyone,

I would like to make a macros to extract text within parentheses and all countries names in order of apearence within 2 open word documents and combine them on a new document for revision.
I suppose I have to provide the list of countries

I have a macro to extract and put on a table text within parentheses but it only works for one document. I want to add extraction of all countries listed in the doc too. and that it processes both open documents. There is no need for autosave since its only for revision.

Here the macro for extracting text within parentheses.

Sub ExtractText()
Dim cDoc As Word.Document, nDoc As Word.Document
Dim cRng As Word.Range, nRng As Word.Range

Set cDoc = ActiveDocument
Set nDoc = Documents.Add

Set cRng = cDoc.Content
Set nRng = nDoc.Content

cRng.Find.ClearFormatting
With cRng.Find
.Forward = True
.Text = "("
.Wrap = wdFindStop
.Execute
Do While .Found


cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:=")", Count:=Word.wdForward
nRng.FormattedText = cRng.FormattedText
nRng.InsertParagraphAfter
nRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Execute
Loop
End With
End Sub


thanks a lot

[d4okeefe]

The sub that you pasted pretty much does what you want, right? It accounts for 2 documents, the first one that you search, and the second one the code creates, and that you paste to. If you want to search 2 existing documents, open them by their file locations rather than using ActiveDocument:

Sub open_docs()
    Dim doc_name1 As String
    Dim doc1 As Document
    doc_name1 = "c:\[location]\Doc1.docx"
    Set doc1 = Documents.Open(doc_name1)
    
    Dim doc_name2 As String
    Dim doc2 As Document
    doc_name1 = "c:\[location]\Doc2.docx"
    Set doc2 = Documents.Open(doc_name1)
End Sub

You can then access the range objects of both "doc1" and "doc2".

You can get a list of country names here, but I'm not sure why you would need it.

[XRope]

Hi d4okeefe,



thanks for replying. Yes i want 2 docs to be searched and results to be shown in a new doc with 2 columns for comparison.


The macro should be a "Search and Extract" for text in () and countries listed in both Doc 1 and Doc 2, thats why I need to integrate a list of countries into the macro but I dont know where and how.


Its important that entries sould be extracted and combined in order of appearance in both docs.


I hope it's clear.

[d4okeefe]

I drew this up. See if you can adjust the variables to make it work. The arrays, arr1 and arr2, will ensure that the country names remain in order when pasting.

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

[XRope]

I have set the path for the 2 Docs to be searched, It starts searching but I get an empty new Doc. Not even the text in () is extracted.


Do I also have to enter the list of countries in



new_doc_rng.Text = "Countries from Doc1:" & vbCrLf


and


new_doc_rng.Text = "Countries from Doc2:" & vbCrLf

[d4okeefe]

Hmm. Do you know how to step through document while debugging?

If so, set the breakpoint at "doc2.Close", then check the two arrays (arr1 & arr2) to see if they have any values loaded. There could be a problem with the search.

[d4okeefe]

Something like this. In the Locals window, you can see that arr1 is filled with values.

[XRope]

I get a

Visual Bais error 9
Subscript out of range


i dont know how to enter through the document while debugging or set a break point, can you tell me or direct me to a tutorial for that



is there a way to enter the list manually into the macro ?

[d4okeefe]

Error 9 means that the arr1 or arr2 variable has a problem. Make sure that these lines:

Dim arr1(1 To 1000)
Dim arr2(1 To 1000)

... appear in your code. Or, possibly, there are more than 1000 countries in your search. If so, you could increase the size of the array to 10000.

Better, yet paste your code, and let's take a look. If you can, click the # sign above, so that your code is formatted.

Here's Microsoft's VBA tutorial.

[XRope]

You were right, more than 1000 countries thats why it didnt work.


tried with a smaller file, what I got was the text in () from both documents but not on 2 columns facing each other.


No countries though and I think its because I didnt enter them in arrays 1 and 2, how do I do that ?

[XRope]

I managed to set a break point where you told me, the values in arr1 and arr2 are the text in () from both Docs but no country names.

[d4okeefe]

To get the text into two columns, you can do something like this. Notice that variables arr1 and arr2 already need to be filled with your data.

I hope that helps. Better yet, as I mentioned, it might be good to see your code. Since you aren't terribly used to working with VBA, it would be easy to have a variable misnamed or out of place.

    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

[XRope]

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

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

[d4okeefe]

Have you ever seen the countries printed to the new document? Or, does the new document contain no data?

[XRope]

Then new Doc contains only the text in () as expected in 2 columns


no country names, logivwly i dont expect them to appear untill i "tell" the macro to namely look for them.



I could add them for Doc1 and Doc2 as "Albania", "Algeria",...... but where ???


in rng1 and rng2 ?

.Text ="\(*\)"


or here
If arr1(x) <> "" Then