如何在word文档中定位特定字符串并用Excel VBA脚本替换为自动目录？

我正在用Excel编写一个VBA脚本，它需要将目录添加到特定位置预先存在的word文档中

Sub createContentsPage()

Dim objWord As Word.Application
Dim inputDoc As Word.Document
Dim rngWord As Word.Range

Set objWord = New Word.Application

With objWord
    .Visible = True
    Set inputDoc = .Documents.Open( _
            Filename:="C:\test.docx", _
            ReadOnly:=False)
End With

'Create table of contents at top of document
With inputDoc
    Set rngWord = .Range(Start:=0, End:=0)      
    .TablesOfContents.Add _
    Range:=rngWord, _
    UseFields:=True, _
    UseHeadingStyles:=True, _
    LowerHeadingLevel:=2, _
    UpperHeadingLevel:=1
End With

'Scroll to top of document
objWord.Selection.HomeKey Unit:=wdStory

'Select contents table
objWord.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'Cut contents table
objWord.Selection.Cut

'Find placeholder and delete (cursor will remain at place holder)
With inputDoc.Content.Find
    .Text = "[contents_table_placeholder]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .ExecuteReplace:=wdReplaceOne
End With

'Insert new line
objWord.Selection.TypeParagraph

'Paste contents table
objWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)

inputDoc.Save
inputDoc.Close

Set objWord = Nothing
Set inputDoc = Nothing
Set rngWord = Nothing

End Sub

我有一个word文档，其中某处有以下文本：[内容\表格\占位符]

我想找到文本[contents\u table\u placeholder]，并将其替换为word文档自动内容表

但是，我很难让目录显示在文档开头以外的任何地方。我最初的方法是查找并替换（用空字符串替换[contents\u table\u placeholder]）。我认为这会将光标放在正确的位置，然后添加目录，但不幸的是，这种方法不起作用

Sub createContentsPage()

Dim objWord As Word.Application
Dim inputDoc As Word.Document
Dim rngWord As Word.Range

Set objWord = New Word.Application

With objWord
    .Visible = True
    Set inputDoc = .Documents.Open( _
                Filename:="C:\test.docx", _
                ReadOnly:=False)
End With

With inputDoc.Content.Find
    .Text = "[contents_table_placeholder]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .ExecuteReplace:=wdReplaceOne
End With

With inputDoc
    Set rngWord = .Range(Start:=0, End:=0)

    .TablesOfContents.Add _
        Range:=rngWord, _
        UseFields:=True, _
        UseHeadingStyles:=True, _
        LowerHeadingLevel:=2, _
        UpperHeadingLevel:=1
End With

Set objWord = Nothing
Set inputDoc = Nothing
Set rngWord = Nothing

End Sub

---

在其他尝试失败后，我提出了以下变通解决方案，包括首先在文档顶部创建目录，然后剪切并粘贴到所需位置

Sub createContentsPage()

Dim objWord As Word.Application
Dim inputDoc As Word.Document
Dim rngWord As Word.Range

Set objWord = New Word.Application

With objWord
    .Visible = True
    Set inputDoc = .Documents.Open( _
            Filename:="C:\test.docx", _
            ReadOnly:=False)
End With

'Create table of contents at top of document
With inputDoc
    Set rngWord = .Range(Start:=0, End:=0)      
    .TablesOfContents.Add _
    Range:=rngWord, _
    UseFields:=True, _
    UseHeadingStyles:=True, _
    LowerHeadingLevel:=2, _
    UpperHeadingLevel:=1
End With

'Scroll to top of document
objWord.Selection.HomeKey Unit:=wdStory

'Select contents table
objWord.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'Cut contents table
objWord.Selection.Cut

'Find placeholder and delete (cursor will remain at place holder)
With inputDoc.Content.Find
    .Text = "[contents_table_placeholder]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .ExecuteReplace:=wdReplaceOne
End With

'Insert new line
objWord.Selection.TypeParagraph

'Paste contents table
objWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)

inputDoc.Save
inputDoc.Close

Set objWord = Nothing
Set inputDoc = Nothing
Set rngWord = Nothing

End Sub

---

此外，这可能会对你有所帮助：这两种方法都不起作用。我仍然不明白为什么，但最终我找到了一个解决办法，就是在文档的开头创建表，然后添加一些代码行以剪切并粘贴到正确的位置。很高兴听到这个消息。您应该将此解决方法作为答案发布，以便以后人们可以找到它。谢谢