PDA

View Full Version : Problem adding strings to doc


axiomcrs
06-19-2013, 08:00 AM
I cannot write an array of strings with each array value followed by newline or by cr and lf or by paragraph to a word document. I keep getting overflow errors. Writing one value from the array is fine. Writing the same string separated by spaces with a loop is fine. I have ven tried join which did not work. What is the preferred way of doing this? My code is below (the latest attempt which is in the code below with the insertafter also causes an overflow error). I am using Word 2010. I should add that the first time the macro runs it works, but the second and subsequent times it causes Run-time error 6 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 Long
Dim y As Long
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim namestotal As Integer
Dim printdebug As Integer


j = 0
printdebug = 0

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" 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\. )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(1)
re.Pattern = "(m\(1\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True

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 UBound(names)
MsgBox j & " = " & names(j)
Next j
End If

printdebug = 0
'Indent array to give illusion of 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
ActiveDocument.Content.InsertAfter (namesindented(1))
ActiveDocument.Content.InsertAfter (vbCr & vbLf)
ActiveDocument.Content.InsertAfter (namesindented(2))


End Sub
SamT
06-24-2013, 06:09 PM
Please use the Green VBA button to put VBA Code tags around your code. You can paste the code, select it and click the button, or click the button, then paste the code in between the tags.

I have done it for you this time.

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 Long
Dim y As Long
Dim lngMin As Long
Dim lngMax As Long
Dim temp1 As String
Dim temp2 As String
Dim namestotal As Integer
Dim printdebug As Integer


j = 0
printdebug = 0

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" 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\. )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(1)
re.Pattern = "(m\(1\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(2)
re.Pattern = "(m\(2\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
'Get married name that follows m(3)
re.Pattern = "(m\(3\) )([\'\.a-zA-Z ]+)"
Set mymatches = re.Execute(Rng.Text)
If mymatches.Count = 1 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)
End If
End If
If Rng.Text = "INDEX" Then Exit Do
.start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True

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 UBound(names)
MsgBox j & " = " & names(j)
Next j
End If

printdebug = 0
'Indent array to give illusion of 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
ActiveDocument.Content.InsertAfter (namesindented(1))
ActiveDocument.Content.InsertAfter (vbCr & vbLf)
ActiveDocument.Content.InsertAfter (namesindented(2))


End Sub
fumei
06-25-2013, 02:58 PM
ActiveDocument.Content.InsertAfter (namesindented(1)) & vbCrLf

???