title: Exporting Table of Contents from Word to Excel
body: <p>I am looking for a way to get the table of contents (not created but headings available) from word and store the chapter numbers and headings on Excel. Is there a method using Excel VBA to take those headings from word doc to excel? I have searched for this but everybody suggest using paste special however I want it automated since the data from TOC is sorted into a different table in Excel afterwards.</p>
  
  <pre><code>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 " &amp; SaveName)
  MsgBox ("Please Accept Delete Operation")
  Sheets("Temp").Delete
  ActiveWorkbook.Save
  End Sub
  </code></pre>