Macro optimization

donsnow · #1 10-31-2017, 05:34 AM

Hello all,

I've written a small macro that does the following:

put the level 5 headings from a document in a table at a certain location in the same document
insert section breaks at certain places in the document
change the page orientation for certain sections
remove some empty paragraphs to get rid of blank pages

It works more or less as I want it to, however, the problems is that I need to use it on large documents (~600 pages, containing a couple of hundreds of heading5s), which either takes a long time or crashes Word.
My question is if it is possible to do this in a more optimal way. This is the first time I'm fiddling with VBA, so I don't really know how to approach this performance issue.

See my code below, any input is appreciated!

Code:

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

To get into specifics:

I attached a sample document
I need the sections because in one of them there is a picture that fits better in landscape. In another section, the table that the macro creates also fits only in a landscape page.
The contents of the document are given and shouldn't be modified, I must only add this table containing all the heading 5 items.
The structure of the document doesn't change, and as far as my tests went until now, the macro managed to keep the correct headers and footers, so for the beginning I would stick with the existing solution,

Thanks again for your help.

macropod · #2 11-09-2017, 07:20 AM

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

donsnow · #3 11-24-2017, 04:53 AM

Hello macropod,

sorry for not replying in such a long time, I was on vacation. Thank you for the great help you've provided. Yours solution does everything I need and the code will for sure serve as reference when I'll try to write some other scripts as well.

Thanks again!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Fixed last page header/footer without the use of section breaks	HelpNeed	Word VBA	2	06-27-2017 06:15 PM
Table of contents with section breaks (text in table in header)	Dmonk	Word	2	05-23-2017 04:29 AM
Auto section break macro - want to have no header on first page of document	cspeid03	Word	1	05-17-2017 12:18 PM
Hidden page breaks and section breaks	jrasicmark	Word	3	06-02-2014 11:28 PM
Deleted Section Breaks Changes Page Breaks	Brantnshellie	Word	0	02-01-2009 09:22 PM