Extract Word paragraphs

NdNoviceHlp

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,631
From XL, I'm trying to search a summary document for a keyword, then copy the paragraph containing the keyword to another document.
I want to be able to do this for a variable amount of paragraphs. Currently, the following code finds the keyword in summary.doc (once) and then copies it to test.doc It's a start. I can't seem to find a way to select and copy the paragraph (even once). The keyword is always on line1 and the paragraph is always 4 lines if that helps? I'll appreciate any suggestions. Thanks. Dave
Code: 
Private Sub CommandButton1_Click()
Dim Wdapp As Object, Wdapp2 As Object
Dim MyData As DataObject, Bigstring As String
'finds and extracts paragraphs from summary.doc to test.doc
'identifies paragraphs by key word in 1st line
'copies paragraph to clipboard then transfer to test.doc
'variable # of paragraphs to copy/transfer
On Error GoTo Evlmsg1
Set Wdapp = CreateObject("Word.application")
    Wdapp.ChangeFileOpenDirectory "c:\records\"
    Wdapp.documents.Open Filename:="summary.doc"
    With Wdapp.activedocument
     .Range(0, .Characters.Count).Select
    End With
 'keyword "seed" eg
 With Wdapp.Selection.Find
    .ClearFormatting
    .Execute FindText:="seed", Format:=False, Forward:=True
    '***line below errors
    '.Expand Unit:=wdParagraph
 End With
With Wdapp.Selection
.Range.Copy
End With
Wdapp.activedocument.Close savechanges:=True
Returntocode:
On Error GoTo 0
Wdapp.Quit
Set Wdapp = Nothing
Set MyData = New DataObject
    MyData.GetFromClipboard
    Bigstring = MyData.GetText(1)
On Error GoTo Evlmsg2
Set Wdapp2 = CreateObject("Word.Application")
    Wdapp2.ChangeFileOpenDirectory "c:\"
    Wdapp2.documents.Open Filename:="test.doc"
'use to initial clear test.doc
    With Wdapp2.activedocument
    .Range(0, .Characters.Count).Delete
    End With
With Wdapp2.activedocument
    .content.insertafter Bigstring
    End With
Wdapp2.activedocument.Close savechanges:=True
Wdapp2.Quit
Set Wdapp2 = Nothing
Exit Sub
Evlmsg1:
MsgBox "error1"
GoTo Returntocode
Evlmsg2:
On Error GoTo 0
Wdapp2.Quit
Set Wdapp2 = Nothing
MsgBox "Error2"
End Sub
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
I changed the Folder and file name in the code below.

I also changed the way the found paragraph is worked with, it now is pasted on to the Excel sheet in A1.

Sub myFind()
'Standard Sheet module, like: Sheet1.
Dim Wapp As Object
Dim Message$, Title$, Default$, myTopic$, myData$
'Finds and extracts paragraphs from summary.doc!

'Get topic from user!
Message = "Enter a topic to find:" ' Set prompt.
Title = "Get Topic!" ' Set title.
Default = "Wholesale" ' Set default.
' Display message, title, and default value.
myTopic = InputBox(Message, Title, Default)

'Open data WORD document to search!
On Error GoTo Err1
Set Wapp = CreateObject("Word.Application")
Wapp.Documents.Open Filename:="U:/Excel/Data/summary7.doc", ReadOnly:=True

If Wapp.Application.Documents.Count >= 1 Then
MsgBox "[ " & Wapp.ActiveDocument.Name & " ] is open!"
Else
MsgBox "No documents are open"
End If

'Find myTopic in the data WORD document!
RetErr1:
On Error GoTo Err2
Wapp.ActiveDocument.Select
With Wapp.Selection.Find
.Text = myTopic
.Forward = True
.Execute

If .Found = True Then
MsgBox "Searching data WORD document for: [ " & myTopic & " ]!"

'Select paragraph "myTopic" was found in, the WORD data document, and copy it!
On Error GoTo Err3
.Parent.Expand Unit:=wdParagraph

'Copy found data!
On Error GoTo Err4
myData = Wapp.Selection.Text
MsgBox myData
Else
myData = "No data to copy!"
GoTo Err2
End If
End With

'Put data into Sheet1 A1!
Sheets("Sheet1").Range("A1").Value = myData

'Close data WORD document!
On Error GoTo Err5
RetErr2:
RetErr3:
RetErr4:
Wapp.Quit
GoTo myEnd

'Error messages!
Err1:
MsgBox "Error1: Could not open WORD document!"
GoTo RetErr1

Err2:
MsgBox "Error2: Could not Find Topic: [ " & myTopic & " ]"
GoTo RetErr2

Err3:
MsgBox "Error3: Could not get paragraph from the data's WORD document!"
GoTo RetErr3

Err4:
MsgBox "Error4: Could not Paste paragraph from the data's WORD document!"
GoTo RetErr4

Err5:
MsgBox "Error5: Could not Close the data's WORD document!"


'End tag!
myEnd:
End Sub
 
Upvote 0
Joe Wow! Thank you. There's alot to be learned there. I'm still getting an error 3 message. Does it matter that the documents contents were created by XL? Thanks for your time and that great coding. I considered simply placing the contents into a cell but that was after I took the time to figure out the clipboard thing so I stuck with it. Maybe I'll figure a work around to this line of code that doesn't want to work for me. Dave
 
Upvote 0
:oops: I was messing with the references and had the reference to the Word library unchecked when I trialled Joe's code. It now works...sort of. It copies line 1 of 4 to A1 with an odd small square box at the end of the line?
I trialled the code with a "normal" Word document paragraph and the code works great...copying the whole paragraph. Perhaps my interpretation of 4 lines of text grouped together doesn't satisfy Word's paragraph definition? I'm very pleased with the success so far. I guess I still need to figure out how to copy all 4 lines as well as how to ensure that the reference to the Word library is set. Again thanks for any assistance. Dave
 
Upvote 0
Set the paragraph symbol on in the WORD options.

Now check to see if you have a paragraph with those 4 lines?

WORD checks for a Begining Hard or Soft-return character and Ending Hard or Soft-return character to determin paragraphs.
 
Upvote 0
I guess I'm actually trying to copy the found paragraph and the next 3 paragraphs. Handy Word option that I wasn't aware of. The paragraph(s) creation I assume is caused by the Vbcrlf command used in the document creation. Is it even going to be possible to copy the found paragraph along with the next three paragraphs? I added the following bit of code after the copy to sheet1!A1 to get rid of the annoying little square thing that was showing up at the end of the copied line. Dave
Code: 
strtest = [sheet1!A1]
For i = 1 To Len(strtest)
  temp = Asc(Mid(strtest, i, 1))
  If temp <> 13 Then
  newstring = newstring + Mid(strtest, i, 1)
  End If
  Next i
[sheet1!A1] = newstring
 
Upvote 0
A Success update. The code below now copies the found paragraph plus 3 more. Just need to loop and transfer to another document. There must be some way to do that? Dave
Code: 
Sub myFind()
'Standard Sheet module, like: Sheet1.
Dim Wapp As Object
Dim Message$, Title$, Default$, myTopic$, myData$
Dim strtest As String, flag As Boolean, newstring As String
Dim temp As Integer, i As Integer, myrange As Variant
'Finds and extracts paragraphs from summary.doc!

'Get topic from user!
Message = "Enter a topic to find:" ' Set prompt.
Title = "Get Topic!" ' Set title.
Default = "Wholesale" ' Set default.
' Display message, title, and default value.
myTopic = InputBox(Message, Title, Default)

'Open data WORD document to search!
On Error GoTo Err1
Set Wapp = CreateObject("Word.Application")
Wapp.Documents.Open Filename:="c:\records\summary.doc", ReadOnly:=True

If Wapp.Application.Documents.Count >= 1 Then
MsgBox "[ " & Wapp.ActiveDocument.Name & " ] is open!"
Else
MsgBox "No documents are open"
End If

'Find myTopic in the data WORD document!
RetErr1:
On Error GoTo Err2
Wapp.ActiveDocument.Select
With Wapp.Selection.Find
.Text = myTopic
.Forward = True
.Execute

If .Found = True Then
MsgBox "Searching data WORD document for: [ " & myTopic & " ]!"

'Select paragraph "myTopic" was found in, the WORD data document, and copy it!
On Error GoTo Err3
.Parent.Expand Unit:=wdParagraph
On Error GoTo Err4
'add next three paragaphs to selection
Set myrange = Wapp.ActiveDocument.Paragraphs(Wapp.Selection.Information(wdFirstCharacterLineNumber)).Range
myrange.SetRange Start:=myrange.Start, _
    End:=ActiveDocument.Paragraphs(Wapp.Selection.Information(wdFirstCharacterLineNumber) + 3).Range.End
myrange.Select
myData = Wapp.Selection.Text
MsgBox myData
Else
myData = "No data to copy!"
GoTo Err2
End If
End With
'Put data into Sheet1 A1!
Sheets("Sheet1").Range("A1").Value = myData
'get rid of square thingee
strtest = [sheet1!A1]
For i = 1 To Len(strtest)
  temp = Asc(Mid(strtest, i, 1))
  If temp <> 13 Then
  newstring = newstring + Mid(strtest, i, 1)
  End If
  Next i
[sheet1!A1] = newstring
On Error GoTo Err5
RetErr2:
RetErr3:
RetErr4:
Wapp.Quit
GoTo myEnd
'Error messages!
Err1:
MsgBox "Error1: Could not open WORD document!"
GoTo RetErr1

Err2:
MsgBox "Error2: Could not Find Topic: [ " & myTopic & " ]"
GoTo RetErr2

Err3:
MsgBox "Error3: Could not get paragraph from the data's WORD document!"
GoTo RetErr3

Err4:
MsgBox "Error4: Could not Paste paragraph from the data's WORD document!"
GoTo RetErr4

Err5:
MsgBox "Error5: Could not Close the data's WORD document!"


'End tag!
myEnd:
End Sub
 
Upvote 0
Project complete! This code tranfers the found paragraph and the 4 following paragraphs to the test document (an additional blank paragraph to format the test document). Didn' t need to remove the square thingee so I removed that part of the code. Thanks to all for the help. Dave
Code: 
Sub myFind()
'Standard module
Dim Wapp As Object, Wapp2 As Object, myData2 As DataObject, mydata3 As DataObject
Dim Message$, Title$, Default$, myTopic$, myData$, Adjust As Integer
Dim Bigstring2 As String, Myrange As Variant, Myrange2 As Variant
'Finds and extracts 5 paragraphs from summary.doc!
Dim ThisParaLoc As Integer, LastParaLoc As Integer, Bigstring As String
Dim Cleardocflag As Boolean
'Get topic from user!
Message = "Enter a topic to find:" ' Set prompt.
Title = "Get Topic!" ' Set title.
Default = "Wholesale" ' Set default.
' Display message, title, and default value.
myTopic = InputBox(Message, Title, Default)
'Open data WORD document to search!
On Error GoTo Err1
Set Wapp = CreateObject("Word.Application")
Wapp.Documents.Open Filename:="c:\records\summary.doc", ReadOnly:=True
'ckeck if document exists
If Wapp.Application.Documents.Count >= 1 Then
MsgBox "[ " & Wapp.ActiveDocument.Name & " ] is open!"
Else
MsgBox "No documents are open"
End If
'Find myTopic in the data WORD document!
RetErr1:
On Error GoTo Err2
'find last paragraph
Wapp.ActiveDocument.Select
LastParaLoc = Wapp.Selection.Paragraphs.Count
ThisParaLoc = 0
Cleardocflag = False
'loop to find all records
Do While ThisParaLoc < LastParaLoc
Set Myrange2 = Wapp.ActiveDocument.Paragraphs(ThisParaLoc + 1).Range
Myrange2.SetRange Start:=Myrange2.Start, _
    End:=Wapp.ActiveDocument.Paragraphs(LastParaLoc).Range.End
Myrange2.Select
With Wapp.Selection.Find
.Text = myTopic
.Forward = True
.Execute
If .Found = True Then
MsgBox "Searching data WORD document for: [ " & myTopic & " ]!"
'Select paragraph "myTopic" was found in, the WORD data document, and copy it!
On Error GoTo Err3
.Parent.Expand Unit:=wdParagraph
On Error GoTo Err4
'add next 4 paragaphs to selection
'adjust for pages
If Wapp.Selection.Information(wdActiveEndPageNumber) > 1 Then
Adjust = Wapp.Selection.Information(wdActiveEndPageNumber) * 46 - 46
End If
Set Myrange = Wapp.ActiveDocument.Paragraphs _
(Wapp.Selection.Information(wdFirstCharacterLineNumber) + Adjust).Range
Myrange.SetRange Start:=Myrange.Start, _
    End:=Wapp.ActiveDocument.Paragraphs(Wapp.Selection.Information _
    (wdFirstCharacterLineNumber) + 4 + Adjust).Range.End
ThisParaLoc = Wapp.Selection.Information(wdFirstCharacterLineNumber) + 4 + Adjust
Myrange.Select
myData = Wapp.Selection.Text
MsgBox myData
Else
Exit Do
End If
End With
'move to clipboard
Set mydata3 = New DataObject
    mydata3.SetText myData
    mydata3.PutInClipboard
'get from clipboard
Set myData2 = New DataObject
    myData2.GetFromClipboard
    Bigstring2 = myData2.GetText(1)
'transfer from clipboard to file
Set Wapp2 = CreateObject("Word.Application")
Wapp2.Documents.Open Filename:="c:\test.doc", ReadOnly:=False
Wapp2.ActiveDocument.Select
 With Wapp2.ActiveDocument
    If Cleardocflag = False Then
    .Range(0, .Characters.Count).Delete
    Cleardocflag = True
    End If
    .content.insertafter Bigstring2
    End With
Wapp2.ActiveDocument.Close savechanges:=True
Wapp2.Quit
Set Wapp2 = Nothing
Loop
On Error GoTo Err5
RetErr2:
RetErr3:
RetErr4:
Wapp.ActiveDocument.Close savechanges:=True
Wapp.Quit
Set Wapp = Nothing
Set myData2 = Nothing
Set mydata3 = Nothing
GoTo myEnd
'Error messages!
Err1:
MsgBox "Error1: Could not open WORD document!"
GoTo RetErr1
Err2:
MsgBox "Error2: Could not Find Topic: [ " & myTopic & " ]"
GoTo RetErr2
Err3:
MsgBox "Error3: Could not get paragraph from the data's WORD document!"
GoTo RetErr3
Err4:
MsgBox "Error4: Could not Paste paragraph from the data's WORD document!"
GoTo RetErr4
Err5:
MsgBox "Error5: Could not Close the data's WORD document!"
'End tag!
myEnd:
End Sub
edit: removed my previous post now that the project is complete
 
Upvote 0
Had to make some code adjustments to address found groups of paragraphs which were not all on one page. I'm still working on getting rid of the Word library reference if anyone has any suggestions. Dave
Code: 
Sub myFind()
'Standard module
Dim Wapp As Object, Wapp2 As Object, myData2 As DataObject, mydata3 As DataObject
Dim Message$, Title$, Default$, myTopic$, myData$, Adjust As Integer
Dim Bigstring2 As String, Myrange As Variant, Myrange2 As Variant
Dim ThisParaLoc As Integer, LastParaLoc As Integer, Bigstring As String
Dim Cleardocflag As Boolean, FirstParaloc As Integer
'Finds and extracts 5 paragraphs from summary.doc!
'Get topic from user!
Message = "Enter a topic to find:" ' Set prompt.
Title = "Get Topic!" ' Set title.
Default = "Wholesale" ' Set default.
' Display message, title, and default value.
myTopic = InputBox(Message, Title, Default)
'Open data WORD document to search!
On Error GoTo Err1
Set Wapp = CreateObject("Word.Application")
Wapp.Documents.Open Filename:="c:\records\summary.doc", ReadOnly:=True
'ckeck if document exists
If Wapp.Application.Documents.Count >= 1 Then
MsgBox "[ " & Wapp.ActiveDocument.Name & " ] is open!"
Else
MsgBox "No documents are open"
End If
'Find myTopic in the data WORD document!
RetErr1:
On Error GoTo Err2
'find last paragraph
Wapp.ActiveDocument.Select
LastParaLoc = Wapp.Selection.Paragraphs.Count
ThisParaLoc = 0
Cleardocflag = False
'loop to find all records
Do While ThisParaLoc < LastParaLoc
Set Myrange2 = Wapp.ActiveDocument.Paragraphs(ThisParaLoc + 1).Range
Myrange2.SetRange Start:=Myrange2.Start, _
    End:=Wapp.ActiveDocument.Paragraphs(LastParaLoc).Range.End
Myrange2.Select
With Wapp.Selection.Find
.Text = myTopic
.Forward = True
.Execute
If .Found = True Then
MsgBox "Searching data WORD document for: [ " & myTopic & " ]!"
'Select paragraph "myTopic" was found in, the WORD data document, and copy it!
On Error GoTo Err3
.Parent.Expand Unit:=wdParagraph
On Error GoTo Err4
'add next 4 paragaphs to selection
'adjust for pages
If Wapp.Selection.Information(wdActiveEndPageNumber) > 1 Then
If Wapp.Selection.Information(wdFirstCharacterLineNumber) <> 46 Then
Adjust = Wapp.Selection.Information(wdActiveEndPageNumber) * 46 - 46
Else
Adjust = (Wapp.Selection.Information(wdActiveEndPageNumber) - 1) * 46 - 46
End If
End If
FirstParaloc = Wapp.Selection.Information(wdFirstCharacterLineNumber) + Adjust
Set Myrange = Wapp.ActiveDocument.Paragraphs(FirstParaloc).Range
Myrange.SetRange Start:=Myrange.Start, _
    End:=Wapp.ActiveDocument.Paragraphs(FirstParaloc + 4).Range.End
ThisParaLoc = FirstParaloc + 4
Myrange.Select
myData = Wapp.Selection.Text
MsgBox myData
Else
Exit Do
End If
End With
'move to clipboard
Set mydata3 = New DataObject
    mydata3.SetText myData
    mydata3.PutInClipboard
'get from clipboard
Set myData2 = New DataObject
    myData2.GetFromClipboard
    Bigstring2 = myData2.GetText(1)
'transfer from clipboard to file
Set Wapp2 = CreateObject("Word.Application")
Wapp2.Documents.Open Filename:="c:\test.doc", ReadOnly:=False
Wapp2.ActiveDocument.Select
 With Wapp2.ActiveDocument
    If Cleardocflag = False Then
    .Range(0, .Characters.Count).Delete
    Cleardocflag = True
    End If
    .content.insertafter Bigstring2
    End With
Wapp2.ActiveDocument.Close savechanges:=True
Wapp2.Quit
Set Wapp2 = Nothing
Loop
On Error GoTo Err5
RetErr2:
RetErr3:
RetErr4:
Wapp.ActiveDocument.Close savechanges:=True
Wapp.Quit
Set Wapp = Nothing
Set myData2 = Nothing
Set mydata3 = Nothing
GoTo myEnd
'Error messages!
Err1:
MsgBox "Error1: Could not open WORD document!"
GoTo RetErr1
Err2:
MsgBox "Error2: Could not Find Topic: [ " & myTopic & " ]"
GoTo RetErr2
Err3:
MsgBox "Error3: Could not get paragraph from the data's WORD document!"
GoTo RetErr3
Err4:
MsgBox "Error4: Could not Paste paragraph from the data's WORD document!"
GoTo RetErr4
Err5:
MsgBox "Error5: Could not Close the data's WORD document!"
'End tag!
myEnd:
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA to copy from Excel as image and paste in Word
2
Replies
11
Views
2K
NdNoviceHlp
NdNoviceHlp
P
  • Question
Runtime Error 462 when Running Code to Export Excel Values into Word Bookmarks
Replies
6
Views
964
pastelprincess
P
D
  • Question
Run code on selected "sheets" corresponding to the checkboxes on userform.
Replies
3
Views
671
HaHoBe
HaHoBe
J
  • Question
Copy paragraph with certain keyword available under a searched word
Replies
0
Views
392
Jmac2604
J
welshgasman
  • Question
Mailmerge from Excel sheet substituting phone number for 0
Replies
8
Views
503
welshgasman
welshgasman

Forum statistics

Threads
1,215,416
Messages
6,124,772
Members
449,187
Latest member
hermansoa

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top