Vba to create a "Table of content" in MS word and copy it to excel sheet

Question

I am new to vba and newer to using word with excel vba. I am looking for a code which can create "Table of content" in MS word and copy it to excel sheet.

So far I have tried below-

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

Answer 1

Minor tweak:

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