axiomcrs
07-16-2013, 09:07 AM
I have written a macro using Word 2010 and if I run it a second time, the values from the first run seem to add to the values of the second run and each time I run the macro. The macro appends the contents of the Word documents in a particular folder into a new document and then it searches for names. The names are collected into an array and added to the new document as an index. When I run the macro a second time, the total names gets displayed is correct, but the contents of the new document contains what got added from the first run. In other words, from the first run the new document that got created has 28 pages. When I run the macro for a second time, the new document contains 56 pages. I believe that I am starting with a blank document. Any suggestions?
Also, as a second question. Why is it when I comment out this section:
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
the macro causes an overflow?
Sub SearchDocByLine()
Dim RegExp As Object
Set RegExp = CreateObject("vbscript.regexp")
Dim re As RegExp
Set re = New RegExp
re.Pattern = "^[\t\+][0-9]+\."
re.IgnoreCase = True
re.Global = True
Application.ScreenUpdating = False
Dim i As Integer, Rng As Range
Dim intVal As Integer
Dim mymatches As MatchCollection
Dim mymatch As match
Dim names() As String
Dim namesindented() As String
Dim j As Integer
Dim pagenumber As Integer
Dim msgString As String
Dim temp As String
Dim strTemp As String
Dim x As Integer
Dim y As Integer
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim strPos As String
Dim namestotal As Integer
Dim printdebug As Integer
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim z As Integer
'Dim f As Integer
'Const WODDOC As String = "C:\Project2\output\master.doc"
'f = FreeFile
'Open WODDOC For Output As #f 'opens the file in I/O stream
'Close #f 'closes and saves new, blank file
'Shell "winword " & WODDOC, vbMaximizedFocus
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
'Set wrdDoc = wrdApp.Documents.Open("C:\Project2\output\master.doc")
Set wrdDoc = wrdApp.Documents.Add
ChDir "C:\Project2\input"
myName = Dir("*.DOC")
j = 0
printdebug = 0
namestotal = 0
With wrdDoc
'Concatenate files
While myName <> ""
With Selection
.InsertFile FileName:=myName, ConfirmConversions:=False
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
myName = Dir()
Wend
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + 1
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\line")
re.Pattern = "^[\t\+][0-9]+\."
'Test if line contains a descendant
If (re.test(Rng.Text)) Then
If printdebug = 1 Then
MsgBox "Rng.Text=" & Rng.Text
MsgBox "Page num=" & Rng.Information(wdActiveEndPageNumber)
End If
'Get first descendant
re.Pattern = "^([\t\+][0-9]+\.\t)([.a-zA-Z ]+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "infant" And mymatches(0).SubMatches(1) <> "daughter" Then
If printdebug = 1 Then
MsgBox "Desc=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m.
re.Pattern = "(, m\. )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(1)
're.Pattern = "(m\(1\) )([-\'\.a-zA-Z ]+)"
re.Pattern = "(m\(1\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.Start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With 'ActiveDocument.Range
Set Rng = Nothing
Application.ScreenUpdating = True
printdebug = 1
namestotal = j
If printdebug = 1 Then
MsgBox "namestotal=" & namestotal
End If
printdebug = 0
'Rearrange names to be last name first
For j = 1 To namestotal
temp = names(j)
re.Pattern = "([a-zA-Z \.\(\)\? ]+) ([a-zA-z]+)( [0-9]+)$"
Set mymatches = re.Execute(temp)
If mymatches.Count > 0 Then
If printdebug = 1 Then
MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
End If
names(j) = mymatches(0).SubMatches(1) & ", " & mymatches(0).SubMatches(0) & mymatches(0).SubMatches(2)
Else
If printdebug = 1 Then
MsgBox "No match"
End If
End If
Next j
printdebug = 0
If printdebug = 1 Then
For j = 1 To UBound(names)
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 0
'Sort array
lngMin = 1
lngMax = namestotal
For x = lngMin To lngMax - 1
For y = x + 1 To lngMax
If names(x) > names(y) Then
strTemp = names(x)
names(x) = names(y)
names(y) = strTemp
End If
Next y
Next x
printdebug = 0
If printdebug = 1 Then
For j = 1 To namestotal
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 1
'Indent array to produce an index
ReDim Preserve namesindented(namestotal)
namesindented(1) = names(1)
'For j = 2 To namestotal
' re.Pattern = "^([a-zA-Z]+, )"
' Set mymatches = re.Execute(names(j - 1))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp1 = mymatches(0).SubMatches(0)
' End If
' Set mymatches = re.Execute(names(j))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp2 = mymatches(0).SubMatches(0)
' End If
' If printdebug = 1 Then
' MsgBox "temp1=" & temp1 & " temp2=" & temp2
' End If
' If temp1 = temp2 Then
' namesindented(j) = Right(names(j), Len(names(j)) - Len(temp1))
' namesindented(j) = Space(Len(temp1)) & namesindented(j)
' If printdebug = 1 Then
' MsgBox "names=" & names(j) & " namesindented=" & namesindented(j)
' End If
' End If
'Next j
'Write array to doc
For z = 1 To namestotal
ActiveDocument.Content.InsertAfter (names(z)) & vbCrLf
'MsgBox "Written string=" & names(z)
Next z
If Dir("C:\Project2\output\master.docx") <> "" Then
Kill "C:\Project2\output\master.docx"
MsgBox "File master.docx exists"
End If
.SaveAs ("C:\Project2\output\master.docx")
.Close ' close the document
End With 'wrddoc
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
Also, as a second question. Why is it when I comment out this section:
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
the macro causes an overflow?
Sub SearchDocByLine()
Dim RegExp As Object
Set RegExp = CreateObject("vbscript.regexp")
Dim re As RegExp
Set re = New RegExp
re.Pattern = "^[\t\+][0-9]+\."
re.IgnoreCase = True
re.Global = True
Application.ScreenUpdating = False
Dim i As Integer, Rng As Range
Dim intVal As Integer
Dim mymatches As MatchCollection
Dim mymatch As match
Dim names() As String
Dim namesindented() As String
Dim j As Integer
Dim pagenumber As Integer
Dim msgString As String
Dim temp As String
Dim strTemp As String
Dim x As Integer
Dim y As Integer
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim strPos As String
Dim namestotal As Integer
Dim printdebug As Integer
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim z As Integer
'Dim f As Integer
'Const WODDOC As String = "C:\Project2\output\master.doc"
'f = FreeFile
'Open WODDOC For Output As #f 'opens the file in I/O stream
'Close #f 'closes and saves new, blank file
'Shell "winword " & WODDOC, vbMaximizedFocus
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
'Set wrdDoc = wrdApp.Documents.Open("C:\Project2\output\master.doc")
Set wrdDoc = wrdApp.Documents.Add
ChDir "C:\Project2\input"
myName = Dir("*.DOC")
j = 0
printdebug = 0
namestotal = 0
With wrdDoc
'Concatenate files
While myName <> ""
With Selection
.InsertFile FileName:=myName, ConfirmConversions:=False
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
myName = Dir()
Wend
With Selection
.TypeText Text:="INDEX"
.InsertParagraphAfter
.InsertParagraphAfter
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + 1
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\line")
re.Pattern = "^[\t\+][0-9]+\."
'Test if line contains a descendant
If (re.test(Rng.Text)) Then
If printdebug = 1 Then
MsgBox "Rng.Text=" & Rng.Text
MsgBox "Page num=" & Rng.Information(wdActiveEndPageNumber)
End If
'Get first descendant
re.Pattern = "^([\t\+][0-9]+\.\t)([.a-zA-Z ]+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
If mymatches(0).SubMatches(1) <> "infant" And mymatches(0).SubMatches(1) <> "daughter" Then
If printdebug = 1 Then
MsgBox "Desc=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
End If
End If
'Get married name that follows m.
re.Pattern = "(, m\. )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m.=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(1)
're.Pattern = "(m\(1\) )([-\'\.a-zA-Z ]+)"
re.Pattern = "(m\(1\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m1=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m2=" & mymatches(0).SubMatches(1)
End If
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )(
+),"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 Then
strPos = InStr(mymatches(0).SubMatches(1), "------")
If strPos = 0 Then
If printdebug = 1 Then
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
j = j + 1
ReDim Preserve names(j)
names(j) = mymatches(0).SubMatches(1) & " " & Rng.Information(wdActiveEndPageNumber)
Else
MsgBox "m3=" & mymatches(0).SubMatches(1)
End If
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.Start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With 'ActiveDocument.Range
Set Rng = Nothing
Application.ScreenUpdating = True
printdebug = 1
namestotal = j
If printdebug = 1 Then
MsgBox "namestotal=" & namestotal
End If
printdebug = 0
'Rearrange names to be last name first
For j = 1 To namestotal
temp = names(j)
re.Pattern = "([a-zA-Z \.\(\)\? ]+) ([a-zA-z]+)( [0-9]+)$"
Set mymatches = re.Execute(temp)
If mymatches.Count > 0 Then
If printdebug = 1 Then
MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
End If
names(j) = mymatches(0).SubMatches(1) & ", " & mymatches(0).SubMatches(0) & mymatches(0).SubMatches(2)
Else
If printdebug = 1 Then
MsgBox "No match"
End If
End If
Next j
printdebug = 0
If printdebug = 1 Then
For j = 1 To UBound(names)
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 0
'Sort array
lngMin = 1
lngMax = namestotal
For x = lngMin To lngMax - 1
For y = x + 1 To lngMax
If names(x) > names(y) Then
strTemp = names(x)
names(x) = names(y)
names(y) = strTemp
End If
Next y
Next x
printdebug = 0
If printdebug = 1 Then
For j = 1 To namestotal
MsgBox j & " = " & names(j)
Next j
End If
printdebug = 1
'Indent array to produce an index
ReDim Preserve namesindented(namestotal)
namesindented(1) = names(1)
'For j = 2 To namestotal
' re.Pattern = "^([a-zA-Z]+, )"
' Set mymatches = re.Execute(names(j - 1))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp1 = mymatches(0).SubMatches(0)
' End If
' Set mymatches = re.Execute(names(j))
' If mymatches.Count > 0 Then
' If printdebug = 1 Then
' MsgBox "M1=" & mymatches(0).SubMatches(0) & " M2=" & mymatches(0).SubMatches(1) & " M3=" & mymatches(0).SubMatches(2)
' End If
' temp2 = mymatches(0).SubMatches(0)
' End If
' If printdebug = 1 Then
' MsgBox "temp1=" & temp1 & " temp2=" & temp2
' End If
' If temp1 = temp2 Then
' namesindented(j) = Right(names(j), Len(names(j)) - Len(temp1))
' namesindented(j) = Space(Len(temp1)) & namesindented(j)
' If printdebug = 1 Then
' MsgBox "names=" & names(j) & " namesindented=" & namesindented(j)
' End If
' End If
'Next j
'Write array to doc
For z = 1 To namestotal
ActiveDocument.Content.InsertAfter (names(z)) & vbCrLf
'MsgBox "Written string=" & names(z)
Next z
If Dir("C:\Project2\output\master.docx") <> "" Then
Kill "C:\Project2\output\master.docx"
MsgBox "File master.docx exists"
End If
.SaveAs ("C:\Project2\output\master.docx")
.Close ' close the document
End With 'wrddoc
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub