Экспорт содержимого из Word в Excel

Question

Я ищу способ получить оглавление (не создано, но заголовки доступны) из слова и сохранить номера разделов и заголовки в Excel. Есть ли метод, использующий Excel VBA, чтобы перенести эти заголовки из слова 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 

Я использую раннее связывание, так что вам нужно будет либо добавить ссылку на объектной модели Word, или подправить код для позднего связывания (в том числе выяснить, числовое значение перечислений).