need help: insert array/matrix data after text?

J

jmmiller

I've created documents where every sentence is its own section. I
want/need to create a table/matrix/some sort of output at the end of
each document that will indicate whether or not each of a list of
words appears in a given section. I want it to output a 1 if the find
function is successful and a 0 if it is not (so it will look like a
matrix/table with each section being a row and each column
representing the presence of a search term).

I want to be able to export the data into excel (to look for
combinations/other analysis/etc.) so any sort of output (separated by
tabs/in a table/anything) would work. I've been trying to get a macro
to do this using a matrix/array to record the data and then just write
it out at the end (I've been trying to get it in a table, listbox,
combobox, etc) but can't seem to get it to work. Macro 1 pasted below
is a short version of as far as I have been able to get.

I do have a macro that gives me the output I am looking for, but
takes an extremely long time (some documents are 400,000 words or so;
there are dozens of documents) because it goes back and forth between
the section it is examining and the end of the document (I will paste
that macro below as macro 2) to write out one line of output at a time
before moving on to the next section. I'm pretty sure the array/matrix
method would be much quicker as it seems most of the time is taken up
going back and forth between a section and the output, but don't know
how to do it.

How do I get the array inserted into the document? Or is there a
better way of doing this? Any suggestions/ideas would be great.

I appreciate any help.


Macro1(does not work, but might be a start; I left my notes/attempts
at a table/listbox in):

Sub Matrix1()
'
' Macro1 Macro
' Macro recorded 5/1/2009 by WITS
'
Dim myRange As Range
Dim IsPresent As Integer
Dim myArray() As String
Dim mySection As Integer
‘Dim ListBox1 As ListBox
Dim myNumWords As Integer
Dim myTotSect As Integer
Dim rtable As Table

myNumWords = 3 ' number of words to search for
myTotSect = ActiveDocument.Sections.Count

ReDim myArray(1 To myTotSect, 1 To myNumWords) As String

For mySection = 1 To myTotSect
Set myRange = ActiveDocument.Sections(mySection).Range

'ListBox1.ColumnCount = myNumWords
'Rows = myTotSect

' You'll have one If statement like the following for each search
word
' This code stores a 1 in the appropriate array entry if the word
is
' found
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 1) = 1
Else
myArray(mySection, 1) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 2) = 1
Else
myArray(mySection, 2) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="salad", Wrap:=wdFindContinue)
Then
myArray(mySection, 3) = 1
Else
myArray(mySection, 3) = 0
End If

Next mySection

'Set rtable = .Tables.Add(Selection.Range, myTotSect, 9)
' With rtable
' For x = 1 to myTotSect
' For y = 1 to 9
' .Cell(x, y).Range.InsertAfter = (myArrary(x,y))
'End With

'ListBox1.List() = myArray()
'ActiveDocument.Range.InsertAfter ListBox1

End Sub



-------------------------------------------------------------------------------------------------
Macro2 (this works and gives me the output I want, but takes much too
long for the length and number of documents I am dealing with):


Sub SentenceWordYesNo()

Application.Windows(ActiveDocument).View = wdNormalView
Application.ScreenUpdating = False
Application.Options.Pagination = False
Application.ActiveDocument.ShowGrammaticalErrors = False
Application.ActiveDocument.ShowSpellingErrors = False

Dim CurrPane As Pane
Set CurrPane = Application.Documents(1).Windows(1).ActivePane

Dim myRange As Range
Dim myWord As Range
Dim i As Long

Dim Unemploy As Long
Dim Inflation As Long
Dim Fullemp As Long
Dim Nairu As Long
Dim Partrate As Long
Dim Labor As Long
Dim Wage As Long
Dim Vacrate As Long
Dim Price As Long

'Selects the active document, collapse to the end,
'and puts a final section break at the end
With ActiveDocument.Range
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With

'Identifies total number of sections as Total minus 1
For i = 1 To ActiveDocument.Sections.Count - 1
''''''''''''''''''''''''' UMEMPLOY
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Unemploy
= 1 Else Unemploy = 0
End With
''''''''''''''''''''''''' Inflation
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Inflation
= 1 Else Inflation = 0
End With
''''''''''''''''''''''''' Employment (Fullemp)
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ee]mployment)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Fullemp =
1 Else Fullemp = 0
End With
''''''''''''''''''''''''' Nairu
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<(NAIRU)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Nairu = 1
Else Nairu = 0
End With
''''''''''''''''''''''''' Participation Rate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Pp]articipation
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Partrate
= 1 Else Partrate = 0
End With
''''''''''''''''''''''''' Labor
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Labor = 1
Else Labor = 0
End With
''''''''''''''''''''''''' Wage
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Wage =1
Else Wage = 0
End With
''''''''''''''''''''''''' Vacrate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Vv]acancy
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Vacrate =
1 Else Vacrate = 0
End With
''''''''''''''''''''''''' Price
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Pp]rice[!d])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Price = 1
Else Price = 0
End With
''''''''''''''''''''''''''
ActiveDocument.Range.InsertAfter Unemploy & vbTab & Inflation
& vbTab & Fullemp & vbTab & Nairu & vbTab & Partrate & vbTab & Labor &
vbTab & Wage & vbTab & Vacrate & vbTab & Price & vbCr

Next i
End Sub
 
P

Pesach Shelnitz

I made some changes to your first macro (Matrix1), and it now works fine for
me.

Here is a list of the main changes that I made.
1) I changed the names of some of your variables for the sake of consistency
and readability. Obviously, these changes did not resolve any coding issue,
and you can feel free to change my variable names back to your original names.
2) I declared the array as a Variant so that it could be redefined using
ReDim as a two-dimensional array of Strings.
3) I put qoutation marks around the numbers 1 and 0 being inserted into the
array, since you indicated that the array should be a two-dimensional array
of Strings.
4) I removed the unnecessary repeated calls to ClearFormatting.
5) I set MatchWildcards to False in the search that doesn't use wildcards.
6) I called the Tables.Add method on ActiveDocument.
7) I rewrote the line to copy each value from the array into the table.

The result is as follows:

Sub Matrix1()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer

numWords = 3 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = 1
Else
myArray(sectNum, 2) = 0
End If

If myRange.Find.Execute(Findtext:="salad", _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = 1
Else
myArray(sectNum, 3) = 0
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub

--
Hope this helps,
Pesach Shelnitz


[email protected] said:
I've created documents where every sentence is its own section. I
want/need to create a table/matrix/some sort of output at the end of
each document that will indicate whether or not each of a list of
words appears in a given section. I want it to output a 1 if the find
function is successful and a 0 if it is not (so it will look like a
matrix/table with each section being a row and each column
representing the presence of a search term).

I want to be able to export the data into excel (to look for
combinations/other analysis/etc.) so any sort of output (separated by
tabs/in a table/anything) would work. I've been trying to get a macro
to do this using a matrix/array to record the data and then just write
it out at the end (I've been trying to get it in a table, listbox,
combobox, etc) but can't seem to get it to work. Macro 1 pasted below
is a short version of as far as I have been able to get.

I do have a macro that gives me the output I am looking for, but
takes an extremely long time (some documents are 400,000 words or so;
there are dozens of documents) because it goes back and forth between
the section it is examining and the end of the document (I will paste
that macro below as macro 2) to write out one line of output at a time
before moving on to the next section. I'm pretty sure the array/matrix
method would be much quicker as it seems most of the time is taken up
going back and forth between a section and the output, but don't know
how to do it.

How do I get the array inserted into the document? Or is there a
better way of doing this? Any suggestions/ideas would be great.

I appreciate any help.


Macro1(does not work, but might be a start; I left my notes/attempts
at a table/listbox in):

Sub Matrix1()
'
' Macro1 Macro
' Macro recorded 5/1/2009 by WITS
'
Dim myRange As Range
Dim IsPresent As Integer
Dim myArray() As String
Dim mySection As Integer
‘Dim ListBox1 As ListBox
Dim myNumWords As Integer
Dim myTotSect As Integer
Dim rtable As Table

myNumWords = 3 ' number of words to search for
myTotSect = ActiveDocument.Sections.Count

ReDim myArray(1 To myTotSect, 1 To myNumWords) As String

For mySection = 1 To myTotSect
Set myRange = ActiveDocument.Sections(mySection).Range

'ListBox1.ColumnCount = myNumWords
'Rows = myTotSect

' You'll have one If statement like the following for each search
word
' This code stores a 1 in the appropriate array entry if the word
is
' found
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 1) = 1
Else
myArray(mySection, 1) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 2) = 1
Else
myArray(mySection, 2) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="salad", Wrap:=wdFindContinue)
Then
myArray(mySection, 3) = 1
Else
myArray(mySection, 3) = 0
End If

Next mySection

'Set rtable = .Tables.Add(Selection.Range, myTotSect, 9)
' With rtable
' For x = 1 to myTotSect
' For y = 1 to 9
' .Cell(x, y).Range.InsertAfter = (myArrary(x,y))
'End With

'ListBox1.List() = myArray()
'ActiveDocument.Range.InsertAfter ListBox1

End Sub



-------------------------------------------------------------------------------------------------
Macro2 (this works and gives me the output I want, but takes much too
long for the length and number of documents I am dealing with):


Sub SentenceWordYesNo()

Application.Windows(ActiveDocument).View = wdNormalView
Application.ScreenUpdating = False
Application.Options.Pagination = False
Application.ActiveDocument.ShowGrammaticalErrors = False
Application.ActiveDocument.ShowSpellingErrors = False

Dim CurrPane As Pane
Set CurrPane = Application.Documents(1).Windows(1).ActivePane

Dim myRange As Range
Dim myWord As Range
Dim i As Long

Dim Unemploy As Long
Dim Inflation As Long
Dim Fullemp As Long
Dim Nairu As Long
Dim Partrate As Long
Dim Labor As Long
Dim Wage As Long
Dim Vacrate As Long
Dim Price As Long

'Selects the active document, collapse to the end,
'and puts a final section break at the end
With ActiveDocument.Range
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With

'Identifies total number of sections as Total minus 1
For i = 1 To ActiveDocument.Sections.Count - 1
''''''''''''''''''''''''' UMEMPLOY
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Unemploy
= 1 Else Unemploy = 0
End With
''''''''''''''''''''''''' Inflation
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Inflation
= 1 Else Inflation = 0
End With
''''''''''''''''''''''''' Employment (Fullemp)
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ee]mployment)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Fullemp =
1 Else Fullemp = 0
End With
''''''''''''''''''''''''' Nairu
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<(NAIRU)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Nairu = 1
Else Nairu = 0
End With
''''''''''''''''''''''''' Participation Rate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Pp]articipation
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Partrate
= 1 Else Partrate = 0
End With
''''''''''''''''''''''''' Labor
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Labor = 1
Else Labor = 0
End With
''''''''''''''''''''''''' Wage
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Wage = 1
Else Wage = 0
End With
''''''''''''''''''''''''' Vacrate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Vv]acancy
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Vacrate =
1 Else Vacrate = 0
End With
''''''''''''''''''''''''' Price
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Pp]rice[!d])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Price = 1
Else Price = 0
End With
''''''''''''''''''''''''''
ActiveDocument.Range.InsertAfter Unemploy & vbTab & Inflation
& vbTab & Fullemp & vbTab & Nairu & vbTab & Partrate & vbTab & Labor &
vbTab & Wage & vbTab & Vacrate & vbTab & Price & vbCr

Next i
End Sub
Click to expand...
 
P

Peter Jamieson

Perhaps worth trying another approach altogether - I do not think it
would take long to set up a test to see if Word's own word search would
be quicker. (It might be a lot slower - I don't know)

1. Create a concordance file, e.g. c:\a\myconcordance.docx, containing
the words you are looking for. So for example if you are looking for
unemploy and inflation, you need a .doc (or .docx) with a two-column
table with

unemploy unemploy
Unemploy unemploy
inflation inflation
Inflation inflation

(you would actually need one row for each different possible "wordform")

2. use the concordance file to create Index Entry (XE) fields:

ActiveDocument.Indexes.AutoMarkEntries _
ConcordanceFileName:="c:\a\myconcordance.docx"

So where the file contains Unemploy you should have

{ XE "unemploy" }

(NB, XE fields are hidden so you have to display hidden text and field
results to see them)

3. Modify the XE entries so they look like this:

{ XE "unemploy" \t { SECTION } }

{ SECTION } is a nested field so you can't just insert the text.
Something like the following should do it:

Sub ChangeXEFields()
Dim f As Word.Field
Dim r As Word.Range
For Each f In ActiveDocument.Fields
If f.Type = wdFieldIndexEntry Then
Set r = f.Code
r.InsertAfter "\t "
r.Collapse direction:=wdCollapseEnd
r.Fields.Add r, wdFieldSection, preserveformatting:=False
End If
Next
End Sub

4. Use an INDEX field to generate an index. You should then have each
indexed word followed by a comma-separated list of sections where the
word appears

5. If that all works quickly and does not suffer from significant
volume-related problems (e.g. the thing grinds to a halt when the word
count reaches a certain size, or has problems outputting very large
lists of section numbers), then you would need code to process the
result of the index field to generate the table you really want.

Peter Jamieson

http://tips.pjmsn.me.uk

I've created documents where every sentence is its own section. I
want/need to create a table/matrix/some sort of output at the end of
each document that will indicate whether or not each of a list of
words appears in a given section. I want it to output a 1 if the find
function is successful and a 0 if it is not (so it will look like a
matrix/table with each section being a row and each column
representing the presence of a search term).

I want to be able to export the data into excel (to look for
combinations/other analysis/etc.) so any sort of output (separated by
tabs/in a table/anything) would work. I've been trying to get a macro
to do this using a matrix/array to record the data and then just write
it out at the end (I've been trying to get it in a table, listbox,
combobox, etc) but can't seem to get it to work. Macro 1 pasted below
is a short version of as far as I have been able to get.

I do have a macro that gives me the output I am looking for, but
takes an extremely long time (some documents are 400,000 words or so;
there are dozens of documents) because it goes back and forth between
the section it is examining and the end of the document (I will paste
that macro below as macro 2) to write out one line of output at a time
before moving on to the next section. I'm pretty sure the array/matrix
method would be much quicker as it seems most of the time is taken up
going back and forth between a section and the output, but don't know
how to do it.

How do I get the array inserted into the document? Or is there a
better way of doing this? Any suggestions/ideas would be great.

I appreciate any help.


Macro1(does not work, but might be a start; I left my notes/attempts
at a table/listbox in):

Sub Matrix1()
'
' Macro1 Macro
' Macro recorded 5/1/2009 by WITS
'
Dim myRange As Range
Dim IsPresent As Integer
Dim myArray() As String
Dim mySection As Integer
‘Dim ListBox1 As ListBox
Dim myNumWords As Integer
Dim myTotSect As Integer
Dim rtable As Table

myNumWords = 3 ' number of words to search for
myTotSect = ActiveDocument.Sections.Count

ReDim myArray(1 To myTotSect, 1 To myNumWords) As String

For mySection = 1 To myTotSect
Set myRange = ActiveDocument.Sections(mySection).Range

'ListBox1.ColumnCount = myNumWords
'Rows = myTotSect

' You'll have one If statement like the following for each search
word
' This code stores a 1 in the appropriate array entry if the word
is
' found
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 1) = 1
Else
myArray(mySection, 1) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 2) = 1
Else
myArray(mySection, 2) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="salad", Wrap:=wdFindContinue)
Then
myArray(mySection, 3) = 1
Else
myArray(mySection, 3) = 0
End If

Next mySection

'Set rtable = .Tables.Add(Selection.Range, myTotSect, 9)
' With rtable
' For x = 1 to myTotSect
' For y = 1 to 9
' .Cell(x, y).Range.InsertAfter = (myArrary(x,y))
'End With

'ListBox1.List() = myArray()
'ActiveDocument.Range.InsertAfter ListBox1

End Sub



-------------------------------------------------------------------------------------------------
Macro2 (this works and gives me the output I want, but takes much too
long for the length and number of documents I am dealing with):


Sub SentenceWordYesNo()

Application.Windows(ActiveDocument).View = wdNormalView
Application.ScreenUpdating = False
Application.Options.Pagination = False
Application.ActiveDocument.ShowGrammaticalErrors = False
Application.ActiveDocument.ShowSpellingErrors = False

Dim CurrPane As Pane
Set CurrPane = Application.Documents(1).Windows(1).ActivePane

Dim myRange As Range
Dim myWord As Range
Dim i As Long

Dim Unemploy As Long
Dim Inflation As Long
Dim Fullemp As Long
Dim Nairu As Long
Dim Partrate As Long
Dim Labor As Long
Dim Wage As Long
Dim Vacrate As Long
Dim Price As Long

'Selects the active document, collapse to the end,
'and puts a final section break at the end
With ActiveDocument.Range
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With

'Identifies total number of sections as Total minus 1
For i = 1 To ActiveDocument.Sections.Count - 1
''''''''''''''''''''''''' UMEMPLOY
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Unemploy
= 1 Else Unemploy = 0
End With
''''''''''''''''''''''''' Inflation
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Inflation
= 1 Else Inflation = 0
End With
''''''''''''''''''''''''' Employment (Fullemp)
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ee]mployment)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Fullemp =
1 Else Fullemp = 0
End With
''''''''''''''''''''''''' Nairu
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<(NAIRU)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Nairu = 1
Else Nairu = 0
End With
''''''''''''''''''''''''' Participation Rate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Pp]articipation
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Partrate
= 1 Else Partrate = 0
End With
''''''''''''''''''''''''' Labor
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Labor = 1
Else Labor = 0
End With
''''''''''''''''''''''''' Wage
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Wage = 1
Else Wage = 0
End With
''''''''''''''''''''''''' Vacrate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Vv]acancy
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Vacrate =
1 Else Vacrate = 0
End With
''''''''''''''''''''''''' Price
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Pp]rice[!d])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Price = 1
Else Price = 0
End With
''''''''''''''''''''''''''
ActiveDocument.Range.InsertAfter Unemploy & vbTab & Inflation
& vbTab & Fullemp & vbTab & Nairu & vbTab & Partrate & vbTab & Labor &
vbTab & Wage & vbTab & Vacrate & vbTab & Price & vbCr

Next i
End Sub
Click to expand...
 
P

Pesach Shelnitz

There is something that I overlooked. Because the searches are performed
within a Range, when a search is successful, the subsequent searches are
performed from the point where the search string was found. As a result, the
macro can miss some of the words that you are searching for. For example, if
"unemploy" and "salad" are both present in the same sentence, but "salad" is
before "unemploy," the macro will not find "salad." To correct this problem,
I added another variable called pos. After myRange is set in each cycle of
the loop, I added a line to save the position of the beginning of the range
(the value of myRange.Start), and then before each search after the first
search, I added a line to reset myRangeStart to the original starting
position of the range. With these changes, the order of the words in each
sentence does not matter.

Here is the revised macro.

Sub Matrix1()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim pos As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer

numWords = 3 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
pos = myRange.Start

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = 1
Else
myArray(sectNum, 2) = 0
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="salad", _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = 1
Else
myArray(sectNum, 3) = 0
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub

--
Hope this helps,
Pesach Shelnitz


Pesach Shelnitz said:
I made some changes to your first macro (Matrix1), and it now works fine for
me.

Here is a list of the main changes that I made.
1) I changed the names of some of your variables for the sake of consistency
and readability. Obviously, these changes did not resolve any coding issue,
and you can feel free to change my variable names back to your original names.
2) I declared the array as a Variant so that it could be redefined using
ReDim as a two-dimensional array of Strings.
3) I put qoutation marks around the numbers 1 and 0 being inserted into the
array, since you indicated that the array should be a two-dimensional array
of Strings.
4) I removed the unnecessary repeated calls to ClearFormatting.
5) I set MatchWildcards to False in the search that doesn't use wildcards.
6) I called the Tables.Add method on ActiveDocument.
7) I rewrote the line to copy each value from the array into the table.

The result is as follows:

Sub Matrix1()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer

numWords = 3 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = 1
Else
myArray(sectNum, 2) = 0
End If

If myRange.Find.Execute(Findtext:="salad", _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = 1
Else
myArray(sectNum, 3) = 0
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub

--
Hope this helps,
Pesach Shelnitz


[email protected] said:
I've created documents where every sentence is its own section. I
want/need to create a table/matrix/some sort of output at the end of
each document that will indicate whether or not each of a list of
words appears in a given section. I want it to output a 1 if the find
function is successful and a 0 if it is not (so it will look like a
matrix/table with each section being a row and each column
representing the presence of a search term).

I want to be able to export the data into excel (to look for
combinations/other analysis/etc.) so any sort of output (separated by
tabs/in a table/anything) would work. I've been trying to get a macro
to do this using a matrix/array to record the data and then just write
it out at the end (I've been trying to get it in a table, listbox,
combobox, etc) but can't seem to get it to work. Macro 1 pasted below
is a short version of as far as I have been able to get.

I do have a macro that gives me the output I am looking for, but
takes an extremely long time (some documents are 400,000 words or so;
there are dozens of documents) because it goes back and forth between
the section it is examining and the end of the document (I will paste
that macro below as macro 2) to write out one line of output at a time
before moving on to the next section. I'm pretty sure the array/matrix
method would be much quicker as it seems most of the time is taken up
going back and forth between a section and the output, but don't know
how to do it.

How do I get the array inserted into the document? Or is there a
better way of doing this? Any suggestions/ideas would be great.

I appreciate any help.


Macro1(does not work, but might be a start; I left my notes/attempts
at a table/listbox in):

Sub Matrix1()
'
' Macro1 Macro
' Macro recorded 5/1/2009 by WITS
'
Dim myRange As Range
Dim IsPresent As Integer
Dim myArray() As String
Dim mySection As Integer
‘Dim ListBox1 As ListBox
Dim myNumWords As Integer
Dim myTotSect As Integer
Dim rtable As Table

myNumWords = 3 ' number of words to search for
myTotSect = ActiveDocument.Sections.Count

ReDim myArray(1 To myTotSect, 1 To myNumWords) As String

For mySection = 1 To myTotSect
Set myRange = ActiveDocument.Sections(mySection).Range

'ListBox1.ColumnCount = myNumWords
'Rows = myTotSect

' You'll have one If statement like the following for each search
word
' This code stores a 1 in the appropriate array entry if the word
is
' found
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 1) = 1
Else
myArray(mySection, 1) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(mySection, 2) = 1
Else
myArray(mySection, 2) = 0
End If

myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="salad", Wrap:=wdFindContinue)
Then
myArray(mySection, 3) = 1
Else
myArray(mySection, 3) = 0
End If

Next mySection

'Set rtable = .Tables.Add(Selection.Range, myTotSect, 9)
' With rtable
' For x = 1 to myTotSect
' For y = 1 to 9
' .Cell(x, y).Range.InsertAfter = (myArrary(x,y))
'End With

'ListBox1.List() = myArray()
'ActiveDocument.Range.InsertAfter ListBox1

End Sub



-------------------------------------------------------------------------------------------------
Macro2 (this works and gives me the output I want, but takes much too
long for the length and number of documents I am dealing with):


Sub SentenceWordYesNo()

Application.Windows(ActiveDocument).View = wdNormalView
Application.ScreenUpdating = False
Application.Options.Pagination = False
Application.ActiveDocument.ShowGrammaticalErrors = False
Application.ActiveDocument.ShowSpellingErrors = False

Dim CurrPane As Pane
Set CurrPane = Application.Documents(1).Windows(1).ActivePane

Dim myRange As Range
Dim myWord As Range
Dim i As Long

Dim Unemploy As Long
Dim Inflation As Long
Dim Fullemp As Long
Dim Nairu As Long
Dim Partrate As Long
Dim Labor As Long
Dim Wage As Long
Dim Vacrate As Long
Dim Price As Long

'Selects the active document, collapse to the end,
'and puts a final section break at the end
With ActiveDocument.Range
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With

'Identifies total number of sections as Total minus 1
For i = 1 To ActiveDocument.Sections.Count - 1
''''''''''''''''''''''''' UMEMPLOY
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Unemploy
= 1 Else Unemploy = 0
End With
''''''''''''''''''''''''' Inflation
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Inflation
= 1 Else Inflation = 0
End With
''''''''''''''''''''''''' Employment (Fullemp)
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:=" <([Ee]mployment)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Fullemp =
1 Else Fullemp = 0
End With
''''''''''''''''''''''''' Nairu
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<(NAIRU)",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Nairu = 1
Else Nairu = 0
End With
''''''''''''''''''''''''' Participation Rate
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Pp]articipation
rate)", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Partrate
= 1 Else Partrate = 0
End With
''''''''''''''''''''''''' Labor
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Labor = 1
Else Labor = 0
End With
''''''''''''''''''''''''' Wage
Set myRange = ActiveDocument.Sections(i).Range
Selection.HomeKey wdStory
With Application.Selection.Find
.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True Then Wage = 1
Else Wage = 0
Click to expand...
Click to expand...
 
J

jmmiller

I updated my macro with your work, but I think I'm still encountering
the problem you tried to address with the revised macro that included
"pos" to restart at the beginning of the section. For example, if I
type "Unemployment inflation employment prices NAIRU labor wages
vacancy rate participation rate" and then run the macro, I only get a
table with a 1 in the first row, first column cell when there should
be a 1 in each cell (also, when I just type in "labor participation
rate" I get 1's in the 6th and 7th boxes which is what I would want -
so I don't know what the problem is).

Do you know why this is happening? I really appreciate the help!

Here is the revised macro with my full word list (9 words) that I'm
using:

Sub Matrix2()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim pos As Integer
Dim rTable As Table
Dim x As Integer
Dim y As Integer

numWords = 9 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
pos = myRange.Start

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = "1"
Else
myArray(sectNum, 2) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:=" <[Ee]mployment", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = "1"
Else
myArray(sectNum, 3) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Pp]rice[!d])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 4) = "1"
Else
myArray(sectNum, 4) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<(NAIRU)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 5) = "1"
Else
myArray(sectNum, 5) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Pp]articipation rate)",
_
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 6) = "1"
Else
myArray(sectNum, 6) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 7) = "1"
Else
myArray(sectNum, 7) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 8) = "1"
Else
myArray(sectNum, 8) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Vv]acancy rate)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 9) = "1"
Else
myArray(sectNum, 9) = "0"
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub


------------------------------------------------------------------------------------------------------------------------------------------------------










There is something that I overlooked. Because the searches are performed
within a Range, when a search is successful, the subsequent searches are
performed from the point where the search string was found. As a result, the
macro can miss some of the words that you are searching for. For example,if
"unemploy" and "salad" are both present in the same sentence, but "salad"is
before "unemploy," the macro will not find "salad." To correct this problem,
I added another variable called pos. After myRange is set in each cycle of
the loop, I added a line to save the position of the beginning of the range
(the value of myRange.Start), and then before each search after the first
search, I added a line to reset myRangeStart to the original starting
position of the range. With these changes, the order of the words in each
sentence does not matter.

Here is the revised macro.

Sub Matrix1()
    Dim myRange As Range
    Dim isPresent As Integer
    Dim myArray As Variant
    Dim sectNum As Integer
    Dim numWords As Integer
    Dim totSect As Integer
    Dim pos As Integer
    Dim rTable As table
    Dim x As Integer
    Dim y As Integer

    numWords = 3 ' number of words to search for
    totSect = ActiveDocument.Sections.Count

    ReDim myArray(1 To totSect, 1 To numWords) As String

    For sectNum = 1 To totSect
        Set myRange = ActiveDocument.Sections(sectNum).Range
        pos = myRange.Start

        ' This code stores a 1 in the appropriate array entry if
        ' the word is found.
        myRange.Find.ClearFormatting
        If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
                MatchWildcards:=True, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 1) = "1"
        Else
            myArray(sectNum, 1) = "0"
        End If

        myRange.Start = pos
        If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
                MatchWildcards:=True, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 2) = 1
        Else
            myArray(sectNum, 2) = 0
        End If

        myRange.Start = pos
        If myRange.Find.Execute(Findtext:="salad", _
                MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 3) = 1
        Else
            myArray(sectNum, 3) = 0
        End If
    Next sectNum

    Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
        NumRows:=totSect, NumColumns:=numWords, _
        DefaultTableBehavior:=wdWord9TableBehavior)
    With rTable
        For x = 1 To totSect
            For y = 1 To numWords
                .Cell(x, y).Range.Text = myArray(x, y)
            Next y
         Next x
    End With
End Sub

--
Hope this helps,
Pesach Shelnitz

Pesach Shelnitz said:
I made some changes to your first macro (Matrix1), and it now works fine for
me.
Click to expand...
Here is a list of the main changes that I made.
1) I changed the names of some of your variables for the sake of consistency
and readability. Obviously, these changes did not resolve any coding issue,
and you can feel free to change my variable names back to your originalnames.
2) I declared the array as a Variant so that it could be redefined using
ReDim as a two-dimensional array of Strings.
3) I put qoutation marks around the numbers 1 and 0 being inserted intothe
array, since you indicated that the array should be a two-dimensional array
of Strings.
4) I removed the unnecessary repeated calls to ClearFormatting.
5) I set MatchWildcards to False in the search that doesn't use wildcards.
6) I called the Tables.Add method on ActiveDocument.
7) I rewrote the line to copy each value from the array into the table.
Click to expand...
The result is as follows:
Click to expand...
Sub Matrix1()
    Dim myRange As Range
    Dim isPresent As Integer
    Dim myArray As Variant
    Dim sectNum As Integer
    Dim numWords As Integer
    Dim totSect As Integer
    Dim rTable As table
    Dim x As Integer
    Dim y As Integer
Click to expand...
    numWords = 3 ' number of words to search for
    totSect = ActiveDocument.Sections.Count
Click to expand...
    ReDim myArray(1 To totSect, 1 To numWords) As String
Click to expand...
    For sectNum = 1 To totSect
        Set myRange = ActiveDocument.Sections(sectNum).Range
Click to expand...
        ' This code stores a 1 in the appropriate array entry if
        ' the word is found.
        myRange.Find.ClearFormatting
        If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
                MatchWildcards:=True, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 1) = "1"
        Else
            myArray(sectNum, 1) = "0"
        End If
Click to expand...
        If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
                MatchWildcards:=True, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 2) = 1
        Else
            myArray(sectNum, 2) = 0
        End If
Click to expand...
        If myRange.Find.Execute(Findtext:="salad", _
                MatchWildcards:=False, _
                Wrap:=wdFindStop, Forward:=True) Then
            myArray(sectNum, 3) = 1
        Else
            myArray(sectNum, 3) = 0
        End If
    Next sectNum
Click to expand...
    Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
        NumRows:=totSect, NumColumns:=numWords, _
        DefaultTableBehavior:=wdWord9TableBehavior)
    With rTable
        For x = 1 To totSect
            For y = 1 To numWords
                .Cell(x, y).Range.Text = myArray(x, y)
            Next y
         Next x
    End With
End Sub
Click to expand...
Click to expand...
 
P

Pesach Shelnitz

I didn't go quite far enough by resetting the start of the range after each
successful search. It is also necessary to reset the end of the range.
Another thing that I noticed in the Matrix2 macro is that some of the
searches have a space before the beginning of the search word. I removed
those spaces. You can put them back if you really meant them to be there.
Here is my revised version of Matrix2.

Sub Matrix2()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim pos1, pos2 As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer

numWords = 9 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
pos1 = myRange.Start
pos2 = myRange.End

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 1) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Ii]nflation)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 2) = "0"
End If

If myRange.Find.Execute(Findtext:="<[Ee]mployment", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 3) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Pp]rice[!d])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 4) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 4) = "0"
End If

If myRange.Find.Execute(Findtext:="<(NAIRU)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 5) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 5) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Pp]articipation rate)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 6) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 6) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 7) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 7) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Ww]age[!r])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 8) = "1"
myRange.Start = pos1
myRange.End = pos2
Else
myArray(sectNum, 8) = "0"
End If

If myRange.Find.Execute(Findtext:="<([Vv]acancy rate)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 9) = "1"
Else
myArray(sectNum, 9) = "0"
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub

--
Hope this helps,
Pesach Shelnitz


[email protected] said:
I updated my macro with your work, but I think I'm still encountering
the problem you tried to address with the revised macro that included
"pos" to restart at the beginning of the section. For example, if I
type "Unemployment inflation employment prices NAIRU labor wages
vacancy rate participation rate" and then run the macro, I only get a
table with a 1 in the first row, first column cell when there should
be a 1 in each cell (also, when I just type in "labor participation
rate" I get 1's in the 6th and 7th boxes which is what I would want -
so I don't know what the problem is).

Do you know why this is happening? I really appreciate the help!

Here is the revised macro with my full word list (9 words) that I'm
using:

Sub Matrix2()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim pos As Integer
Dim rTable As Table
Dim x As Integer
Dim y As Integer

numWords = 9 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
pos = myRange.Start

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:=" <([Ii]nflation)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = "1"
Else
myArray(sectNum, 2) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:=" <[Ee]mployment", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = "1"
Else
myArray(sectNum, 3) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Pp]rice[!d])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 4) = "1"
Else
myArray(sectNum, 4) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<(NAIRU)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 5) = "1"
Else
myArray(sectNum, 5) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Pp]articipation rate)",
_
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 6) = "1"
Else
myArray(sectNum, 6) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Ll]abor[!ie])",
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 7) = "1"
Else
myArray(sectNum, 7) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Ww]age[!r])", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 8) = "1"
Else
myArray(sectNum, 8) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Vv]acancy rate)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 9) = "1"
Else
myArray(sectNum, 9) = "0"
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub


------------------------------------------------------------------------------------------------------------------------------------------------------










There is something that I overlooked. Because the searches are performed
within a Range, when a search is successful, the subsequent searches are
performed from the point where the search string was found. As a result, the
macro can miss some of the words that you are searching for. For example, if
"unemploy" and "salad" are both present in the same sentence, but "salad" is
before "unemploy," the macro will not find "salad." To correct this problem,
I added another variable called pos. After myRange is set in each cycle of
the loop, I added a line to save the position of the beginning of the range
(the value of myRange.Start), and then before each search after the first
search, I added a line to reset myRangeStart to the original starting
position of the range. With these changes, the order of the words in each
sentence does not matter.

Here is the revised macro.

Sub Matrix1()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim pos As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer

numWords = 3 ' number of words to search for
totSect = ActiveDocument.Sections.Count

ReDim myArray(1 To totSect, 1 To numWords) As String

For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
pos = myRange.Start

' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = 1
Else
myArray(sectNum, 2) = 0
End If

myRange.Start = pos
If myRange.Find.Execute(Findtext:="salad", _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = 1
Else
myArray(sectNum, 3) = 0
End If
Next sectNum

Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
For x = 1 To totSect
For y = 1 To numWords
.Cell(x, y).Range.Text = myArray(x, y)
Next y
Next x
End With
End Sub

--
Hope this helps,
Pesach Shelnitz

Pesach Shelnitz said:
I made some changes to your first macro (Matrix1), and it now works fine for
me.
Click to expand...
Here is a list of the main changes that I made.
1) I changed the names of some of your variables for the sake of consistency
and readability. Obviously, these changes did not resolve any coding issue,
and you can feel free to change my variable names back to your original names.
2) I declared the array as a Variant so that it could be redefined using
ReDim as a two-dimensional array of Strings.
3) I put qoutation marks around the numbers 1 and 0 being inserted into the
array, since you indicated that the array should be a two-dimensional array
of Strings.
4) I removed the unnecessary repeated calls to ClearFormatting.
5) I set MatchWildcards to False in the search that doesn't use wildcards.
6) I called the Tables.Add method on ActiveDocument.
7) I rewrote the line to copy each value from the array into the table.
Click to expand...
The result is as follows:
Click to expand...
Sub Matrix1()
Dim myRange As Range
Dim isPresent As Integer
Dim myArray As Variant
Dim sectNum As Integer
Dim numWords As Integer
Dim totSect As Integer
Dim rTable As table
Dim x As Integer
Dim y As Integer
Click to expand...
numWords = 3 ' number of words to search for
totSect = ActiveDocument.Sections.Count
Click to expand...
ReDim myArray(1 To totSect, 1 To numWords) As String
Click to expand...
For sectNum = 1 To totSect
Set myRange = ActiveDocument.Sections(sectNum).Range
Click to expand...
' This code stores a 1 in the appropriate array entry if
' the word is found.
myRange.Find.ClearFormatting
If myRange.Find.Execute(Findtext:="<([Uu]nemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 1) = "1"
Else
myArray(sectNum, 1) = "0"
End If
Click to expand...
If myRange.Find.Execute(Findtext:="<([Uu]nderemploy)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 2) = 1
Else
myArray(sectNum, 2) = 0
End If
Click to expand...
If myRange.Find.Execute(Findtext:="salad", _
MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) Then
myArray(sectNum, 3) = 1
Else
myArray(sectNum, 3) = 0
End If
Next sectNum
Click to expand...
Set rTable = ActiveDocument.Tables.Add(Selection.Range, _
NumRows:=totSect, NumColumns:=numWords, _
DefaultTableBehavior:=wdWord9TableBehavior)
With rTable
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Help with word/phrase counting macro? 3
Word Macro for multiple searches, incl. in footnotes 2
Macro duplicates last comment 2
Counter for macro 3
Need help modifying code 0
Putting 4 macros into 1 macro. Is it possible?? 4
Adding break Lines 1
use range object 5

Top