Sub InsertTable()
    Dim tempTable As Paragraph
    Dim lineCount As Long
    
    Application.ScreenUpdating = False
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
    
    lineCount = 0
    strTableloc = "INSERT TABLE HERE"
    strSection2start = "SECTION 2 START"
    strSection2end = "SECTION 2 END"
    strSection4start = "SECTION 4 START"
    strSection4end = "SECTION 4 END"
    
    For Each tempTable In ActiveDocument.Paragraphs
     If tempTable.Style = ActiveDocument.Styles(wdStyleHeading5) Then
        tempTable.Range.Editors.Add wdEditorEveryone
        lineCount = lineCount + 1
     End If
    Next
    
    ActiveDocument.SelectAllEditableRanges wdEditorEveryone
    Selection.Copy
    Set rng1 = ActiveDocument.Range
    With rng1
        With .Find
            .Text = strTableloc
            If .Execute = True Then
                ActiveDocument.Range(rng1.Start, rng1.End).Select
            End If
        End With
    End With

    Selection.TypeParagraph
    Selection.PasteAndFormat (wdFormatPlainText)
    'select the whole list
    Selection.MoveUp Unit:=wdLine, Count:=lineCount, Extend:=wdExtend
    'create table from the list
    Selection.ConvertToTable Separator:=wdSeparateByTabs, _
        NumColumns:=6, NumRows:=lineCount ', AutoFitBehavior:=wdAutoFitFixed
    With Selection.Tables(1)
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .LeftPadding = 0
        .RightPadding = 0
    End With
    
    Selection.Cut
    Selection.PasteAppendTable
    
    InsertSectionBrake strSection2start
    InsertSectionBrake strSection2end
    InsertSectionBrake strSection4start
    InsertSectionBrake strSection4end
    
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToAbsolute, Count:=2
    Selection.PageSetup.Orientation = wdOrientLandscape
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToAbsolute, Count:=4
    Selection.PageSetup.Orientation = wdOrientLandscape
    
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
    Application.ScreenUpdating = True
    
End Sub

Sub InsertSectionBrake(reference)

    Set rng1 = ActiveDocument.Range
        With rng1
            With .Find
                .Text = reference
                If .Execute = True Then
                    ActiveDocument.Range(rng1.Start, rng1.End).Select
                End If
            End With
        End With
        
    Selection.InsertBreak Type:=wdSectionBreakNextPage
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=2

End Sub

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