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

Question

我有一个项目，我正在编写 VBA 代码来创建一个宏来从数百个单独的单词文档中检索特定段落。 在这里，我的代码允许我选择要检索的文件，然后为段落梳理我的文件。 我的段落在“职位职责：（列出工作中未列出的任何职位特定职责/职责）”之后开始。 并在“位置特定”一词之前结束。 然后代码是复制整个选定的段落并将其粘贴到我指定的单元格（F2）中。 我遇到麻烦的地方是它并不总是正确地检索我的段落。 有时它会离开开头或切断结尾。 我还没有找到正确找到段落结尾的方法，而是用段落编号代替。 不幸的是，段落编号会根据选择的文档而变化。 我也无法找到一种方法来循环这个，以便我可以将每个新段落粘贴到后续行中（F2-->F3-->F4-->等）。 任何帮助是极大的赞赏。

当前代码：

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

一种有点不同的方法：

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

如果要保留开头段落，请删除/注释掉：

.Start = .Paragraphs.First.Range.End