Word VB Code to find character pattern, cut, move to end of document

[Techgirl7]

I have several 1000 page documents that I need to separate single lines of text from paragraphs of text. The only thing I see is different is the single line of text looks like below...

"text 1", "text 2" (doesn't go to the next line and has a quote on the same line)

Paragraph of text is...first line does NOT have an ending quote, but continues on to the end of the paragraph, then has the quote.
"text 1", text 2
***
***
*** "

I need to complete this as soon as possible and need the code to find each single line, cut and paste to the end of the document. So I can easily move into another document.

Any help is appreciated.
Techgirl7

[gmaxey]

Maybe something like this. It simply finds single line paragraphs:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
Dim oCol As New Collection
Dim lngIndex As Long
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
oRng.Collapse wdCollapseStart
oRng.Select
If oPar.Range.Characters.Last.Previous.InRange(Selection.Bookmarks("\Line").Range) Then
oCol.Add oPar.Range
End If
Next oPar
Set oRng = ActiveDocument.Range
oRng.Collapse wdCollapseEnd
oRng.InsertBefore vbCr
For lngIndex = 1 To oCol.Count
oRng.InsertAfter oCol(lngIndex)
Next
lbl_Exit:
Exit Sub
End Sub

[Techgirl7]

Thank you for your response, but it looks like it it copy/pasting everything; not just the single lines of data. ??

[gmaxey]

That isn't happening here.

You can try:


Sub ScratchMacro()
Dim oDoc1 As Document, oDoc2 As Document
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range
Set oDoc1 = ActiveDocument
Set oDoc2 = Documents.Add
For Each oPar In oDoc1.Paragraphs
Set oRng = oPar.Range
oRng.Collapse wdCollapseStart
oRng.Select
If oPar.Range.Characters.Last.Previous.InRange(Selection.Bookmarks("\Line").Range) Then
oDoc2.Range.InsertBefore oPar.Range.FormattedText
End If
Next oPar
oDoc1.Range.InsertAfter vbCr + vbCr
Set oRng = oDoc1.Range
oRng.Collapse wdCollapseEnd
oRng.InsertAfter "This is what is added" & vbCr & oDoc2.Range.FormattedText
oDoc2.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[Techgirl7]

Can it detect a line that has not wrapped?

[Techgirl7]

I misunderstood your information. I will try the code again.

[Techgirl7]

Is there any code that would look at each line, find two sets of quotes, then cut, paste and move to the bottom of document. "***", "***"

[gmaxey]

What is a an actually example of what you text looks like and what you want it to look like? Show me an example of exactly what you want to copy, cut, paste or whatever and exactly what you want left as is.

[Techgirl7]

"zcap", "community-acquired pneumonia"
"zcar", "CARDIAC:"
"zcard", "CARDIOVASCULAR:"

"zcarpal", "PROCEDURE: The patient was taken to the operating room suite. She was placed in the supine position on the operating room table. All bony prominences were well-padded. The right wrist was identified as the correct operative site during the time-out. After adequate IV sedation was administered by the anesthesiologist, the entire right upper extremity was prepped and draped in standard sterile fashion. Local was injected around the area of the incision using a 50/50 mixture of 1% lidocaine plain mixed with 0.25% Marcaine plain."

The first three lines should be cut and moved.

[gmaxey]

Sub ScratchMacro()
Dim oDoc1 As Document, oDoc2 As Document
'A basic Word macro coded by Greg Maxey
Dim oPar As Paragraph
Dim oRng As Range, oRng2 As Range
Set oDoc1 = ActiveDocument
Set oDoc2 = Documents.Add
For Each oPar In oDoc1.Paragraphs
If Len(oPar.Range.Text) > 1 Then
Set oRng = oPar.Range
oRng.Collapse wdCollapseStart
oRng.Select
If oPar.Range.Characters.Last.Previous.InRange(Selection.Bookmarks("\Line").Range) Then
oPar.Range.Cut
Set oRng2 = oDoc2.Range
oRng2.Collapse wdCollapseEnd
oRng2.Paste
End If
End If
Next oPar
oDoc1.Range.InsertAfter vbCr + vbCr
Set oRng2 = oDoc2.Range
oRng2.Cut
Set oRng = oDoc1.Range
oRng.Collapse wdCollapseEnd
oRng.Paste
oDoc2.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[Techgirl7]

This is almost perfect, except it is picking up characters that are at the end of a line and moving them as well, like a comma, semicolons (;) or colons(:) periods.
The example below should not be moved. The first set of quotes is around "ab02", the "History...the last quote is around 5/20/13." This is all one part and should not be separated or moved.

"abo2", "HISTORY OF PRESENT ILLNESS:
PAST MEDICAL HISTORY: Significant for:
1. Depression. Mother is on Wellbutrin.
2. History of anxiety in 2012.
3. Wisdom teeth removal on 5/20/13."

[gmaxey]

Techgirl7,

Now really, I've spent enough of my free time trying to help you and instead of making any apparent effort to help yourself, you redefine the requirement. The code that I have provided to this point hadn't focused on quotes because the apparent requirement was to move "paragraphs" that were a "single line" to the end of the document. If you are hitting the Enter key (vice Shift+Enter) after each of the first four lines in your example above then you have created five single line paragraphs (not one single paragraph with four line breaks).

Try this:


Sub ScratchMacro2()
'A basic Word macro coded by Greg Maxey
Dim oDoc1 As Document, oDoc2 As Document
Dim oPar As Paragraph
Dim oRng As Range, oRng2 As Range
Dim arrParts() As String
Set oDoc1 = ActiveDocument
Set oDoc2 = Documents.Add

For Each oPar In oDoc1.Paragraphs
If Len(oPar.Range.Text) > 1 Then
Set oRng = oPar.Range
oRng.Collapse wdCollapseStart
oRng.Select
arrParts = Split(Selection.Bookmarks("\Line").Range.Text, Chr(34))
If UBound(arrParts) = 4 Then
oPar.Range.Cut
Set oRng2 = oDoc2.Range
oRng2.Collapse wdCollapseEnd
oRng2.Paste
End If
End If
Next oPar
oDoc1.Range.InsertAfter vbCr + vbCr
Set oRng2 = oDoc2.Range
oRng.End = oRng.End - 1
oRng2.Cut
Set oRng = oDoc1.Range
oRng.Collapse wdCollapseEnd
oRng.Paste
oDoc2.Close wdDoNotSaveChanges
lbl_Exit:
Exit Sub
End Sub

[Techgirl7]

Thank you, I do appreciate your time. I know a little of VBA, I'm no expert; and this was way beyond my knowledge. I do appreciate your help and your expert knowledge.

[Techgirl7]

Hello, I just wanted to let you know I tested this last code and its perfect. Thank you so much, you have no idea how much work you have saved me. Kudos !!