Reputation: 13
I want to retrieve specific paragraphs from hundreds of Word documents.
I have code to select which file to retrieve and then comb my file for a paragraph.
The code is to copy the entire paragraph to cell(F2). It does not always retrieve my paragraph correctly. It sometimes leaves off the very beginning or cuts off the end.
I have not figured out a way to find the end of the paragraph and have substituted a paragraph number instead. Unfortunately, the paragraph number changes depending on which document is selected.
I also have not figured out a way to loop this so that I may paste each new paragraph in the subsequent rows(F2-->F3-->F4-->etc.).
Sub WordToExcel()
Dim Document, Word As Object
Dim File As Variant
Dim srchRng As Word.Range
Application.ScreenUpdating = False
File = Application.GetOpenFilename _
("Word file(*.doc;*.docx;*.txt) ,*.doc;*.docx;*txt", , "Accounts Payable Specialist - Please Select")
If File = False Then Exit Sub
Set Word = CreateObject("Word.Application")
Set Document = Word.Documents.Open(Filename:=File, ReadOnly:=True)
Document.Activate
Set srchRng = Word.ActiveDocument.Content
With srchRng.Find
.Text = "POSITION RESPONSIBILITIES: (List any position specific responsibilities/duties that are not listed on the Job)"
.Execute
If .Found = True Then
Dim numberStart As Long
Dim rnge
numberStart = Len(srchRng.Text) - 3
srchRng.MoveEndUntil Cset:="POSITION SPECIFIC"
Dim myNum As String
myNum = Mid(srchRng.Text, numberStart)
Set rnge = Document.Range(Start:=ActiveDocument.Words(numberStart).Start, End:=Document.Paragraphs(29).Range.End)
rnge.Select
On Error Resume Next
Word.Selection.Copy
ActiveSheet.Range("F2").Select
ActiveSheet.Paste
Document.Close
Word.Quit (wdDoNotSaveChanges)
Application.ScreenUpdating = False
End If
End With
Dim val As String
Dim rng As Range
Set rng = Range("F2:F9")
For Each Cell In rng
val = val & Chr(10) & Cell.Value
Next Cell
With rng
.Merge
.Value = Trim(val)
.WrapText = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.Name = "Tahoma"
End With
Application.ScreenUpdating = True
End Sub
Upvotes: 0
Views: 466
Reputation: 13490
A somewhat different approach:
Sub Demo()
Application.ScreenUpdating = False
Dim File As Variant
File = Application.GetOpenFilename _
("Word file(*.doc;*.docx;*.txt) ,*.doc;*.docx;*txt", , "Accounts Payable Specialist - Please Select")
If File = False Then Exit Sub
Dim WdApp As New Word.Application, WdDoc As Word.Document, WdRng As Word.Range, XlSht As Excel.Worksheet
Set XlSht = ActiveSheet
With WdApp
.Visible = False
Set WdDoc = .Documents.Open(Filename:=File, ReadOnly:=True, AddToRecentFiles:=False)
With WdDoc
With .Range
With .Find
.Text = "POSITION RESPONSIBILITIES:*POSITION SPECIFIC"
.MatchWildcards = True
.Execute
End With
If .Find.Found = True Then
.Start = .Paragraphs.First.Range.End
.End = .Paragraphs.Last.Range.Start
Set WdRng = .Duplicate
With WdRng
With .Find
.Text = "[^13^l]"
.Replacement.Text = "¶"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
End With
.Copy
With XlSht
.Paste Destination:=Range("F2")
.Range("F2").Font.Name = "Tahoma"
.Range("F2").Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart
End With
End If
End With
.Close False
End With
.Quit
End With
Set XlSht = Nothing: Set WdDoc = Nothing: Set WdApp = Nothing
Application.ScreenUpdating = False
End Sub
If you want to keep the beginning paragraph, delete/comment-out:
.Start = .Paragraphs.First.Range.End
Upvotes: 0