[英]Vba to create a "Table of content" in MS word and copy it to excel sheet
我是 vba 的新手,並且是在 excel vba 中使用 word 的新手。 我正在尋找可以在 MS Word 中創建“目錄”並將其復制到 Excel 表的代碼。
到目前為止,我已經嘗試過以下-
Sub PrintHeadings()
Dim wrdApp As Word.Application
Dim wrdDoc As Document
Dim Para As Paragraph
Dim oldstart As Variant
Set wrdApp = CreateObject("Word.Application") 'open word
Set wrdDoc = wrdApp.Documents.Open("C:\Users\mishra19\Desktop\Documents\May 2018 Release\test.Docx", , True, False, , , , , , , , True) 'open file
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView 'avoids crashing if opens on read view
With wrdDoc.ActiveWindow.Selection
.GoTo What:=wdGoToHeading, which:=wdGoToFirst 'go to first heading
MsgBox "x"
Do
Set Para = .Tables(1) 'get first paragraph
Title = Replace(Para.Range.Text, Chr(13), "") 'gets title and remove trailing newline
Debug.Print Title, "pg. "; .Information(wdActiveEndAdjustedPageNumber) 'prints title and page to console
oldstart = .Start 'stores position
.GoTo What:=wdGoToHeading, which:=wdGoToNext 'go to next heading
If .Start <= oldstart Then Exit Do 'if looped around to first section (i.e. new heading is before old heading) we are done
Loop
End With
wrdDoc.Close
wrdApp.Quit
Set Para = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
小調整:
Sub CopyHeadings()
Dim wrdApp As New Word.Application, wrdDoc As Word.Document, wrdRng As Word.Range, r As Long
With wrdApp
.Visible = False
Set wrdDoc = .Documents.Open("C:\Users\mishra19\Desktop\Documents\May 2018 Release\test.Docx", _
ReadOnly:=True, AddToRecentFiles:=False, Visible:=False) 'open file
With wrdDoc
Set wrdRng = .Range(0, 0)
'create a Table of Contents
.TablesOfContents.Add Range:=wrdRng, IncludePageNumbers:=True
'get the TOC entries
With wrdRng.Paragraphs(1).Range.Fields(1).Result
For r = 1 To .Paragraphs.Count
ActiveSheet.Range("A" & r).Value = Split(.Paragraphs(r).Range.Text, vbTab)(0)
ActiveSheet.Range("B" & r).Value = Split(.Paragraphs(r).Range.Text, vbTab)(1)
Next
End With
.Close False
End With
.Quit
End With
Set wrdRng = Nothing: Set wrdDoc = Nothing: Set wrdApp = Nothing
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.