How do you reset the results and values from the first run of a macro?

[axiomcrs]

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

[axiomcrs]

Well I've done a little searching and it looks like my issue is related to the fact that when one specifies Documents.Add it should start a new document just as if one is pressing the New button, but it seems like it does not do that. It seems like it is keeping the contents from the initial run and adding to the contents. Does anyone have any further proof or info to that effect?

[fumei]

May I ask if you are executing this from Excel (or some other Office app)? I am wondering about "When I run the macro a second time".

If you are executing from some other app, I do not see how it is possible to get duplicated content.

if you are executing from Word, i have to ask why you are creating an instance of Word.

[axiomcrs]

I have no specific reason why I am creating an instance of Word. The macro is run from Word. Then I presume I should remove that code?
I was able to circumvent the issue by deleting any content in the document at the start of the macro.

[fumei]

I have no specific reason why I am creating an instance of Word. Then I would suggest you do not do so. Unless you DO have a specific reason all it can do is add an element that can mess up. In fact I suspect it is the cause.