jshea
jshea

Reputation: 13

How to copy and paste specific paragraphs from multiple Word files using Excel VBA?

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

Answers (1)

macropod
macropod

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

Related Questions