MS Excel 宏从多个 word 文件中复制和粘贴特定段落

Question

I have a project where i am writing VBA code to create a macro to retrieve specific paragraphs from hundreds of separate words documents. Here i have code that allows me to select which file i want to retrieve and then combs my file for the paragraph. My paragraph starts after the words "POSITION RESPONSIBILITIES: (List any position specific responsibilities/duties that are not listed on the Job)". And ends before the words "POSITION SPECIFIC". The code is to then copy the entire selected paragraph and paste it into my specified cell(F2). Where i am running into trouble is that 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 properly find the end of the paragraph and have substituted a paragraph number instead. Unfortunately, the paragraph number changes depending on which document is being selected. i also have not been able to figure out a way to loop this so that i may paste each new paragraph in the subsequent rows(F2-->F3-->F4-->etc.). Any help is greatly appreciated.

Current Code:

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```

Answer 1

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