从Excel VBA在Word文档中插入TOC

时间:2018-03-28 19:48:17

标签: vba excel-vba ms-word excel

我有一个Excel工作表,其中包含指向Html文件的链接列表。我循环遍历这些html文件并将每个文件插入到word文档中,同时创建标题1引用,我稍后用它来创建TOC。现在一切都是从excel VBA开始工作,除了TOC部分,我能够使用单词>手动创建TOC。参考>插入TOC。但是,TablesofContents.Add的VBA代码会出错

  

“运行时错误13 - 输入mismacth”

如果我删除了TOC VBA代码,其余的宏运行正如我所料。不太清楚代码有什么问题。

Sub Macro3()
Dim rngA As Range
Dim cell As Range

Set fso = CreateObject("scripting.filesystemobject") 'Need this to interact 
  with the windows filesystem
Set wd = CreateObject("word.application") ' need this to open any word documents


DQ = Chr(34) ' double quote will used later for string processing

Set F = fso.GetFolder(InputBox("Enter location where Collated Document is to 
 be created"))
 orent = Application.InputBox(prompt:="Enter Orientation 1 for Landscape, 0 
 for Portrait ")
Typ = Application.InputBox(prompt:="Enter type")


If orent = 1 Then
    orentt = "Landscape"
ElseIf orent = 0 Then
   orentt = "Portrait"
 End If

 Set rngA = Range("A1", Range("A65536").End(xlUp))

 wd.Documents.Add
  wd.ActiveDocument.SaveAs F & "\" & "TLF_collated.docx"
  wd.Documents.Open F & "\" & "TLF_collated.docx"

With wd.ActiveDocument
    .PageSetup.Orientation = orent
    .Paragraphs.LineUnitAfter = 0
    .Paragraphs.LineUnitBefore = 0
    '.Selection.wholestory
    '.Selection.Font.Name = "Times New Roman"



  End With






 For Each cell In rngA

 If cell.Value = Typ Then


   wd.Selection.Style = ("Heading 1")
    wd.Selection.TypeText Text:=Typ & " " & cell.Offset(0, 1).Value & " : " 
    & cell.Offset(0, 2).Value
    wd.Selection.TypeParagraph
    wd.Selection.InsertFile CStr(Replace(Replace(cell.Offset(0, 4).Formula, 
    "=HYPERLINK(" & DQ, ""), DQ & "," & DQ & cell.Offset(0, 4).Value & DQ & 
       ")", ""))
    wd.Selection.EndKey
    wd.Selection.InsertBreak 3
    wd.Selection.InsertBreak 2



 End If
 Next cell

Set myrange = wd.Selection
    myrange.WholeStory
    myrange.Font.Name = "Arial"
    myrange.ParagraphFormat.SpaceAfter = 0
    myrange.ParagraphFormat.SpaceBefore = 0

     wd.Selection.HomeKey
     wd.Selection.MoveUp

       wd.TablesOfContents.Add myrange, _
                                UseFields:=True, _
                                UseHeadingStyles:=True, _
                                UpperHeadingLevel:=1


wd.ActiveDocument.Save
wd.ActiveDocument.Close


 End Sub

0 个答案:

没有答案