buggabooed
Board Regular
- Joined
- Aug 17, 2012
- Messages
- 112
I have a VBA Script in Word that looks for the information I need (a beginning of a sentence), copies the entire sentence until it hits a ".", and then repeats for all instances. I did not create this script as I'm not that awesome ( I had help from here), and it worked great until the vendor sent in wrinkles this time around. What is happening now, is that there are instances mid-sentence of things like "1.5" and such that have a period in the middle, and it is seeing that and ending the sentence right there instead of the actual end of the sentence. Is there a way around this, like an exception, or another way to do this? I'm not real VBA saavy, or really code saavy for that matter. Any help would be appreciated. Thank you. I have the script below.
Sub ExportL2RintoExcel()
'Set reference in Tools >> References to MS Excel
Dim doc As Document
'Both Word and Excel have a "range" object
'but with completely different methods and properties
'so we need to make it obvious which we're working with
Dim WDrngAll As Word.Range
Dim WDrngFind As Word.Range
Dim WDrngText As Word.Range
Dim appXL As Excel.Application
Dim XLwkb As Excel.Workbook
Dim XLwks As Excel.Worksheet
Dim x As Long, y As Long, z As Long
'Initiate objects
Set doc = ActiveDocument
Set WDrngAll = doc.Content
x = 1
z = 0
'First, count all instances of "L2R" in the text
With WDrngAll.Find
Do While .Execute(FindText:="L2R", Forward:=True) = True
z = z + 1
Loop
End With
If MsgBox("I find " & z & " instances of L2R. Does this look right? " & _
"Click Yes to continue; click No to quit.", vbYesNo) = vbYes Then
'All is good, so let's go!
'Dim an array for our info
z = z + 2
ReDim aryExport(z, 2) As String
'In Word VBA, Find searchs a range of text for a string.
'If found, that range shrinks to encompass only that string.
'So we need to set up a series of ranges: the whole doc content,
'a portion of the content to search, and the part to put in the array.
'Could probably be a bit leaner, but this keeps me away from mistakes!
'Since we searched this and found text, we don't know what it encompasses,
'so we'll reset it
Set WDrngAll = doc.Content
'Our search range is going to be reset within our loop to stretch from
'the end of the Text range to the end of the All range. This way, the
'range keeps shrinking to encompass only from the end of where we just
'came from to the end of the document. To start, then, we need a Text
'range that is just one single point at the top of the doc.
Set WDrngText = WDrngAll.Duplicate
WDrngText.Collapse wdCollapseStart
'Start the search loop
Do
'Initiate Find range
Set WDrngFind = doc.Range(WDrngText.End, WDrngAll.End)
'Find text; TRUE if found
If WDrngFind.Find.Execute(FindText:="L2R", Forward:=True) = True Then
'Found one; WDrngFind now contains only the first found "L2R"
'so we need to stretch the range to encompass the whole word
WDrngFind.MoveEnd wdWord, 1
'Load that into the array
aryExport(x, 1) = Trim(WDrngFind.Text)
'Get the text following
'(I could just keep resetting WDrngFind, but it's too prone to
'human error that I can avoid by using another range object)
Set WDrngText = doc.Range(WDrngFind.End, WDrngFind.End)
'WDrngText is now a single point at the end of the found L2R word
'Move the end forward until we see a period
WDrngText.MoveEndUntil "."
WDrngText.MoveEnd wdCharacter, 1
'Put this text into the array
aryExport(x, 2) = Trim(WDrngText.Text)
x = x + 1
'Done here; the Find range resets at the top of the loop
Else
'L2R not found; end loop
Exit Do
End If
Loop
'At this point, we should have an array full of text elements.
'In the first positions are the L2R words. In the second positions
'are all the text blocks following those words.
'Now we write into Excel.
'Check for open Excel instance; if none, create one
On Error Resume Next
Set appXL = GetObject(, "Excel.Application")
On Error GoTo 0
If appXL Is Nothing Then _
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
'Create workbook; get first sheet
Set XLwkb = appXL.Workbooks.Add
Set XLwks = XLwkb.Worksheets("Sheet1")
'Stop display updating for faster writing
appXL.ScreenUpdating = False
'Write array elements
For y = 1 To x
XLwks.Cells(y + 1, 1) = aryExport(y, 1)
XLwks.Cells(y + 1, 2) = aryExport(y, 2)
Next y
'Reset display
appXL.ScreenUpdating = True
End If
MsgBox "Done!"
End Sub
Sub ExportL2RintoExcel()
'Set reference in Tools >> References to MS Excel
Dim doc As Document
'Both Word and Excel have a "range" object
'but with completely different methods and properties
'so we need to make it obvious which we're working with
Dim WDrngAll As Word.Range
Dim WDrngFind As Word.Range
Dim WDrngText As Word.Range
Dim appXL As Excel.Application
Dim XLwkb As Excel.Workbook
Dim XLwks As Excel.Worksheet
Dim x As Long, y As Long, z As Long
'Initiate objects
Set doc = ActiveDocument
Set WDrngAll = doc.Content
x = 1
z = 0
'First, count all instances of "L2R" in the text
With WDrngAll.Find
Do While .Execute(FindText:="L2R", Forward:=True) = True
z = z + 1
Loop
End With
If MsgBox("I find " & z & " instances of L2R. Does this look right? " & _
"Click Yes to continue; click No to quit.", vbYesNo) = vbYes Then
'All is good, so let's go!
'Dim an array for our info
z = z + 2
ReDim aryExport(z, 2) As String
'In Word VBA, Find searchs a range of text for a string.
'If found, that range shrinks to encompass only that string.
'So we need to set up a series of ranges: the whole doc content,
'a portion of the content to search, and the part to put in the array.
'Could probably be a bit leaner, but this keeps me away from mistakes!
'Since we searched this and found text, we don't know what it encompasses,
'so we'll reset it
Set WDrngAll = doc.Content
'Our search range is going to be reset within our loop to stretch from
'the end of the Text range to the end of the All range. This way, the
'range keeps shrinking to encompass only from the end of where we just
'came from to the end of the document. To start, then, we need a Text
'range that is just one single point at the top of the doc.
Set WDrngText = WDrngAll.Duplicate
WDrngText.Collapse wdCollapseStart
'Start the search loop
Do
'Initiate Find range
Set WDrngFind = doc.Range(WDrngText.End, WDrngAll.End)
'Find text; TRUE if found
If WDrngFind.Find.Execute(FindText:="L2R", Forward:=True) = True Then
'Found one; WDrngFind now contains only the first found "L2R"
'so we need to stretch the range to encompass the whole word
WDrngFind.MoveEnd wdWord, 1
'Load that into the array
aryExport(x, 1) = Trim(WDrngFind.Text)
'Get the text following
'(I could just keep resetting WDrngFind, but it's too prone to
'human error that I can avoid by using another range object)
Set WDrngText = doc.Range(WDrngFind.End, WDrngFind.End)
'WDrngText is now a single point at the end of the found L2R word
'Move the end forward until we see a period
WDrngText.MoveEndUntil "."
WDrngText.MoveEnd wdCharacter, 1
'Put this text into the array
aryExport(x, 2) = Trim(WDrngText.Text)
x = x + 1
'Done here; the Find range resets at the top of the loop
Else
'L2R not found; end loop
Exit Do
End If
Loop
'At this point, we should have an array full of text elements.
'In the first positions are the L2R words. In the second positions
'are all the text blocks following those words.
'Now we write into Excel.
'Check for open Excel instance; if none, create one
On Error Resume Next
Set appXL = GetObject(, "Excel.Application")
On Error GoTo 0
If appXL Is Nothing Then _
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
'Create workbook; get first sheet
Set XLwkb = appXL.Workbooks.Add
Set XLwks = XLwkb.Worksheets("Sheet1")
'Stop display updating for faster writing
appXL.ScreenUpdating = False
'Write array elements
For y = 1 To x
XLwks.Cells(y + 1, 1) = aryExport(y, 1)
XLwks.Cells(y + 1, 2) = aryExport(y, 2)
Next y
'Reset display
appXL.ScreenUpdating = True
End If
MsgBox "Done!"
End Sub
