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