View Single Post
 
Old 11-09-2017, 07:20 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,366
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Try the following code. As you'll see, you really don't need all your indicators for where to insert the breaks. All this stuff:
SECTION 2 START
SECTION 2 END
SECTION 4 START
SECTION 4 END
can be deleted from the document.

What I don't understand, though, is why your document isn't pre-configured with the required Sections & page layouts.
Code:
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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote