打开 Word 文档，复制特定文本，粘贴到 Word 文档中

Question

我有一个 Excel 工作表，其中包含不同标题的列表。这些标题也在 Word 文档中，但在 Word 文档中，也有不必要的信息。 我正在尝试做的并且对我刚刚学习的编码感到抱歉的是：

1. 从 Excel 打开 Word 文档
2. 扫描 Excel 工作表 A 列的所有标题
3. 将标题与 Word 文档中的标题进行比较
4. 如果它们相同，则将它们复制到另一个 Word 文档中（完整的段落直到下一个标题 1）
5. 如果不相同，可以忽略
6. 这应该是一个循环，因此它会扫描它，直到找到并复制 Excel 中的所有标题

到目前为止我尝试的是这样的：

Sub Search_Word_Document()

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("file:///J:\Test.docx")

With ActiveDocument.Content.Find
FindWord = Columns("A:A").Value
With .Style = ActiveDocument.Styles("Heading 1")


wrdApp.Selection.WholeStory
wrdApp.Selection.Find.ClearFormatting
With wrdApp.Selection.Find

.Text = FindWord
.Forward = True
.Style = ActiveDocument.Styles("Heading1")
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False


End With

End Sub

它可以很好地打开文档，但是从列中查找文本绝对不能像查找标题那样工作。 感谢您的帮助。

Answer 1

与此同时，我想出了这个：

Sub Align_With_Word_Document()
    Dim wordApp As Word.Application
    Set wordApp = GetObject("", "Word.Application")
    wordApp.Visible = True

    Dim newWordDoc As Word.Document
    Set newWordDoc = wordApp.Documents.Add

    Dim wordDoc As Word.Document
    Set wordDoc = wordApp.Documents.Open("file:///J:\Test.docx")
    wordDoc.Activate


    Dim headings As Collection
    Set headings = wordDoc.Application.Run("NewMacros.extractHeadings")

    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")

    Dim counter As Long
    counter = 1
    Dim currentHeading As Long
    currentHeading = 1
    Do While ws.Cells(counter, 1) <> ""
        Dim ExpectedHeading As String
        ExpectedHeading = ws.Cells(counter, 1)

        Dim lookupHeading As Long
        lookupHeading = currentHeading
        Do While lookupHeading <= headings.Count
            If InStr(1, headings(lookupHeading).Text, ExpectedHeading, vbTextCompare) = 1 Then
                Exit Do
            End If
            lookupHeading = lookupHeading + 1
        Loop

        If lookupHeading <= headings.Count Then
            currentHeading = lookupHeading
            Debug.Print "Found heading '" & ExpectedHeading & "'" & " at index " & currentHeading
            headings(currentHeading).Copy

            Set Target = newWordDoc.Content
            Target.Collapse Direction:=wdCollapseEnd
            Target.Paste
        Else
            MsgBox "Could not find '" & ExpectedHeading & "'"
        End If

        counter = counter + 1
    Loop

    wordApp.Quit

    If currentHeading <= headings.Count Then
        MsgBox "Done"
    End If
End Sub

我现在的问题是它会自动关闭所有内容。但是我想保持一切打开并稍后保存，有人可以帮我吗？ 此外，它仅从我定义的特定文件中加载数据，是否有可能加载文件夹的文档？

Answer 2

试试：

Sub Demo()
'Note: A reference to the Word library must be set, via Tools|References
Const StrDocNm As String = "file:///J:\Test.docx"
If Dir(StrDocNm) = "" Then Exit Sub
Dim WkSht As Worksheet, LRow As Long, r As Long
Dim wdApp As New Word.Application, wdRng As Word.Range
Dim wdDocTgt As Word.Document, wdDocSrc As Word.Document
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdDocSrc = wdApp.Documents.Open(Filename:=StrDocNm, ReadOnly:=False, AddToRecentfiles:=False)
Set wdDocTgt = wdApp.Documents.Add
With wdDocSrc
    'process the source document
    With .Range
      For r = 1 To LRow
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = WkSht.Range("A" & r).Text
          .Style = wdStyleHeading1
          .Replacement.Text = ""
          .Format = True
          .Forward = True
          .Wrap = wdFindContinue
          .Execute
        End With
        If Find.Found = True Then
          Set wdRng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
          wdDocTgt.Range.Characters.Last.FormattedText = wdRng.FormattedText
        End If
      Next
    End With
    .Close SaveChanges:=False
End With
wdApp.Visible = True
Set wdRng = Nothing: Set wdDocSrc = Nothing: Set wdDocTgt = Nothing: Set wdApp = Nothing
End Sub