Option Explicit

Sub InsertSummaryTable()
Application.ScreenUpdating = False
Dim RngTbl As Range, RngSctn As Range
With ActiveDocument.Range
  With .Find
    .Text = "Chapter 2"
    .Style = "Heading 1"
    .Format = True
    .Wrap = wdFindContinue
    .Execute
  End With
  If .Find.Found = True Then
    Set RngSctn = .Paragraphs.Last.Next.Range.Paragraphs.Last.Range
    With RngSctn
      .Characters.First.InsertBreak wdSectionBreakNextPage
      .Start = .Start + 1
      .Sections.First.PageSetup.DifferentFirstPageHeaderFooter = False
      .End = .End + 1
      .Characters.Last.InsertBreak wdSectionBreakNextPage
      .Sections.First.PageSetup.Orientation = wdOrientLandscape
    End With
  End If
  With .Find
    .Text = "Chapter 3"
    .Style = "Heading 1"
    .Execute
  End With
  If .Find.Found = True Then
    Set RngSctn = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    Set RngTbl = RngSctn.Tables(1).Range.Characters.Last.Next.Paragraphs.First.Range
    With RngSctn
      .End = .End + 1
      .Characters.First.InsertBreak wdSectionBreakNextPage
      .Characters.Last.InsertBreak wdSectionBreakNextPage
      .Start = .Start + 1
      .Sections.First.PageSetup.Orientation = wdOrientLandscape
    End With
    ActiveDocument.TablesOfContents.Add Range:=RngTbl, _
      RightAlignPageNumbers:=False, UseHeadingStyles:=True, _
      UpperHeadingLevel:=5, LowerHeadingLevel:=5, _
      IncludePageNumbers:=False, UseHyperlinks:=False
    DoEvents
    With RngTbl
      .End = .End + 1
      .End = .Fields(1).Result.End
      .Fields(1).Unlink
      .ConvertToTable Separator:=wdSeparateByTabs, _
        NumColumns:=6, NumRows:=.Paragraphs.Count, AutoFit:=False
      DoEvents
      With .Tables(1)
        .Borders.Enable = True
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .Range.Cut
      End With
    End With
    RngSctn.Tables(1).Select
    Selection.Collapse wdCollapseEnd
    Selection.PasteAppendTable
  End If
End With
Application.ScreenUpdating = True
End Sub