vba - 将目录从 Word 导出到 Excel

Question

我正在寻找一种方法来从 word 中获取目录(未创建但标题可用)并将章节编号和标题存储在 Excel 上。是否有使用 Excel VBA 将这些标题从 word doc 转换为 excel 的方法？我已经搜索过这个，但每个人都建议使用特殊粘贴，但我希望它自动化，因为之后来自 TOC 的数据被分类到 Excel 中的另一个表中。

Sub importwordtoexcel()
    MsgBox ("This Macro Might Take a While, wait until next Message")
    Application.ScreenUpdating = False
    Sheets("Temp").Cells.Clear

     'Import all tables to a single sheet
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim TableNo As Integer 'table number in Word
    Dim iRow As Long 'row index in Word
    Dim jRow As Long 'row index in Excel
    Dim iCol As Integer 'column index in Excel
    wdFileName = Application.GetOpenFilename("Word files               (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
    If wdDoc.Tables.Count = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    Else
        jRow = 0
        For TableNo = 1 To wdDoc.Tables.Count
            With .Tables(TableNo)
                 'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    jRow = jRow + 1
                    For iCol = 1 To .Columns.Count
                        On Error Resume Next
                        Sheets("Temp").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        On Error GoTo 0
                    Next iCol
                Next iRow
            End With
            jRow = jRow + 1
        Next TableNo
    End If
End With
Set wdDoc = Nothing

'Takes data from temp to RTM_FD
Dim nRow As Long
Dim mRow As Long
Dim Temp As Worksheet
Dim RTM As Worksheet
Set Temp = Sheets("Temp")
Set RTM = Sheets("RTM_FD")

mRow = 16
For nRow = 1 To Temp.Rows.Count
    If Temp.Cells(nRow, 1).Value = "Position" Or Temp.Cells(nRow, 1).Value = "" Then
    Else
        RTM.Cells(mRow, 1).Value = Temp.Cells(nRow, 1)
        RTM.Cells(mRow, 2).Value = Temp.Cells(nRow, 4)
        RTM.Cells(mRow, 2).Font.Bold = False
        RTM.Cells(mRow, 3).Value = Temp.Cells(nRow, 5)
        RTM.Cells(mRow, 3).Font.ColorIndex = 32
        If Temp.Cells(nRow, 3).Value = "P" Then
            RTM.Cells(mRow, 9).Value = "X"
            RTM.Cells(mRow, 9).Interior.ColorIndex = 44
        ElseIf Temp.Cells(nRow, 3) = "Q" Then
            RTM.Cells(mRow, 7).Value = "X"
            RTM.Cells(mRow, 7).Interior.ColorIndex = 44
        ElseIf Temp.Cells(nRow, 3) = "TA" Then
            RTM.Cells(mRow, 8).Value = "X"
            RTM.Cells(mRow, 8).Interior.ColorIndex = 44
        Else
        End If
        mRow = mRow + 1
    End If
Next nRow

Application.ScreenUpdating = True
MsgBox ("DONE")
Sheets("Temp").Cells.Clear
Dim SaveName As String
SaveName = InputBox("What Do You Want to Save the File As:")
ActiveWorkbook.SaveAs (SaveName)
MsgBox ("Your file is saved as " & SaveName)
MsgBox ("Please Accept Delete Operation")
Sheets("Temp").Delete
ActiveWorkbook.Save
End Sub

Answer 1

在不创建目录的情况下获取节标题的一种方法是迭代选择对象，使用 Selection.Goto .以下示例将文档中的所有部分标题打印到即时窗口。我相信你可以将这个概念适应你的代码。

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:\sample.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
    Do
      Set Para = .Paragraphs(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

我使用早期绑定(bind)，因此您需要添加对 Word 对象模型的引用，或者将代码调整为后期绑定(bind)(包括找出枚举的数值)。