Extract List of terms and combine on a Table

d4okeefe · #16 06-29-2018, 12:27 PM

Ok, I'm not sure I follow.

Essentially, this macro
(1) opens 2 original documents
(2) searches each document for text within parentheses
(3) saves that text into 2 arrays (arr1 and arr2)
(4) creates a new document
(5) inserts text from arr1 and arr2 into the new document

It runs from start to finish without any user involvement. How do you want to change this?

XRope · #17 06-29-2018, 12:50 PM

You got it right

the only thing to add to the search are the country names present in both Docs.

so point 2 should be like this

(2) searches each document for text within parentheses and country names.

d4okeefe · #18 06-29-2018, 01:24 PM

For some reason I thought that country names are set within parentheses.

Are some not in parentheses? Is this where the *list* of country names comes in -- the one that you mentioned yesterday?

XRope · #19 06-29-2018, 01:30 PM

no, sorry for the misunderstanding.

the 2 docs have text in parentheses (which are reference numbers)
the rest is text with country names, etc.

so I need the refence numbers in parentheses as well as the country names in the rest of the text.

I hope its clear now

XRope · #20 06-29-2018, 01:54 PM

Here is an example of what i need to extract from both documents:
anything between () and any country names listed in the text. All in order of apearence

Lorem ipsum dolor (ABC12345) sit amet, consectetuer France adipiscing elit. Aenean commodo ligula eget dolor. Aenean (ABC12345) massa. Cum sociis Spain natoque penatibus etc...

d4okeefe · #21 06-29-2018, 03:29 PM

Hmm. I did have that wrong.

Ok. You can get the references in parentheses with the subroutine we've been working on.

It can be tricky to get the country names, because the country names may not be uniform. You could have "Brazil" in one spot, and an official name like "Federative Republic of Brazil" in another.

Nevertheless, I played around with this a bit, and came up with something. I tried to keep it simple enough that you could try it out. However, it is quite long, so I'm including as an attachment.

By the way, you have to paste this at the top of a module. The User-Defined Type has to be placed there.

Again, hope this is helpful.

XRope · #22 06-29-2018, 03:38 PM

dont worry about the country names I dont need that many only around 50 to 60.

what do you mean at the top of a module ?
you mean before the previous macro ?

d4okeefe · #23 06-29-2018, 03:46 PM

The first text in the VBA view needs to be this ...

Code:

Private Type CountriesFoundInDoc
    Name As String
    Location As Long
End Type

By the way, this only pastes the text to the top of the current document. You can adjust to make it add to the new document, but that may take some work. Actually, it was a bit of work to get the info itself.

Good luck.

XRope · #24 06-30-2018, 02:03 PM

Thank you for thr code. I edited it to have less countries, I only need 69.

Here the full code

As you said It only pastes the list of countries of the active document at the top.

I dont know why there is Option Explicit entry at the beginning and
Edit/Delete Message at the end.

Code:

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

When I run It it gives me this windows where I have to choose between the 2 macros Pic.1

the first macro works only if a Doc1 or Doc2 are open.

if i chosse the second macro it tells me Syntax error Pic.2

isnt it possible to expand the search () array to add the countries array into it ??

XRope · #25 06-30-2018, 02:55 PM

there should be some kind of String somewhere in the code to contain all country names.

maybe something similar to this

https://codereview.stackexchange.com...om-html-tables

macropod · #26 07-01-2018, 07:50 PM

Cross-posted at: https://www.office-forums.com/thread...-docs.2350350/
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

XRope · #27 07-02-2018, 02:23 AM

Hi macropod,

sorry fot the cross-posting, understood.

its just that I need to finish this project asap.

thanks anyway

XRope · #28 07-03-2018, 04:00 AM

Could the country names be added in such a way ???

Code:

 
Dim Word As Range
Dim WordCollection(2) As String
Dim Words As Variant
 
WordCollection(0) = "Albania"
WordCollection(1) = "Algeria"
WordCollection(2) = "Austria"
etc.

How can I make it work since I need around 69 country names ???
Plus I would need a dialog box to select the 2 docs from different locations.

d4okeefe · #29 07-10-2018, 08:50 AM

Where are you at in this project? (I returned from vacation.)

To respond to your most recent post, you initialize an array with parentheses, like so:

Code:

Dim WordCollection() as String

To also give the array a size, you can add a number or range inside the parentheses.

Code:

Dim WordCollection(70) As String

The elements available in this array are 0 through 70.

Or

Code:

Dim WordCollection(1 to 70) As String

The elements available here are 1 to 70.

Once the array is initialized, you can assign values to it.

Code:

WordCollection(0) = "Albania"
WordCollection(1) = "Algeria"
WordCollection(2) = "Austria"

XRope · #30 07-12-2018, 01:16 AM

Hi d4okeefe,

hope you enjoyed your holidays.
The project is still standing. I couldnt manage to integrate the country list to search both documents. It only searches the ActiveDocument.
dont know which variables to put to have it search Doc1 and Doc2.

Plus I get results like "Italia" twice because the macro picks the word "Italia" from "Italia" and "Italian".

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Need macro to make list of "defined terms"	glnz	Word VBA	8	09-07-2022 02:09 PM
How to extract names from a list	flyoverrunner	Excel	3	06-06-2018 04:54 AM
Best Practice for Indexing Multiple Word Terms and Sub-Terms	jhy001	Word	4	11-06-2017 02:08 PM
How to Combine a Table of Contents Page with Another Document	Dante49	Word	2	10-24-2016 01:53 PM
Need to extract two word domains from a list (BULK)	Maxwell314	Excel	3	12-08-2014 06:17 PM