Combine multiple word files into 1 document and add section breaks

svo · #1 08-04-2015, 12:51 AM

Hello guys!

I need an idea how to make my process a bit better. I have a macro that combines files within a folder to a base document and inserts section breaks after each one so i can restart page numbering. This works for about 10 documents (with 10 to 15 pages) but hangs up if there a more files in the directory. Usually it will be like 300 documents in there (which will result in a master file with approx 3.2k pages)

The Problem seems to be that after every paste, words built-in renumbering takes place. And because the document gets longer and longer, there will be a moment when it locks up.

the documents I combine are linearized (only consist of 1 section), so that page numbers will reset after every new pasted document in the master document.

Maybe there is a page limit for word? Would it work better with word 2010? The process works nicely at a small scale but can not cope with the production scale.

Here is my Code:

Code:

Sub CombineAll(sPath As String)
    Dim baseDoc As Document, sFile As String
    Set baseDoc = Application.Documents.Add

    sFile = Dir(sPath & "*.doc")

    'Loop through all .doc files in that path
    Do While sFile <> ""

       Set sourceDoc = Application.Documents.Open(sPath & sFile)
       Application.Selection.WholeStory
       Application.Selection.Copy
       Application.ActiveWindow.Close savechanges:=wdDoNotSaveChanges
       baseDoc.Activate

       Application.Selection.PasteAndFormat (wdFormatOriginalFormatting)
       Selection.InsertBreak Type:=wdSectionBreakNextPage

       sFile = Dir
    Loop
End Sub


Sub RebuildNumbering()
    ' Renumber pages
    Dim sc As Integer: sc = ActiveDocument.Sections.Count
    For S = 1 To sc
        Selection.GoTo What:=wdGoToSection, Count:=S

        'Unlink sections from each other
 ActiveDocument.Sections(S).Footers(wdHeaderFooterFirstPage).LinkToPrevious = False
        With ActiveDocument.Sections(S).Footers(wdHeaderFooterFirstPage)
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.NumberStyle = wdPageNumberStyleArabic
            .PageNumbers.StartingNumber = 1
        End With
    Next S
End Sub

gmayor · #2 08-04-2015, 01:42 AM

Rather than copy and paste which is slow and gobbles memory, use InsertFile e.g. as follows. The DoEvents command should prevent it appearing to hang.
Note that combining documents works best when all are based on the same template (including and especially the basedoc).

Code:

Sub CombineAll(sPath As String)
Dim baseDoc As Document, sFile As String
Dim oRng As Range
    On Error GoTo err_Handler
    Set baseDoc = Application.Documents.Add
    sFile = Dir(sPath & "*.doc")
    'Loop through all .doc files in that path
    Do While sFile <> ""
        Set oRng = baseDoc.Range
        oRng.Collapse wdCollapseEnd
        oRng.InsertFile sPath & sFile
        Set oRng = baseDoc.Range
        oRng.Collapse wdCollapseEnd
        oRng.InsertBreak Type:=wdSectionBreakNextPage
        sFile = Dir
        DoEvents
    Loop
    MsgBox "Process complete"
lbl_Exit:
    Set baseDoc = Nothing
    Set oRng = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

A document of 3000+ pages will be slow to process, but is well within Word's capabilities. Hopefully the documents do not contain illustrations as this will make the document even more ponderous.

svo · #3 08-04-2015, 01:46 AM

Hi Graham!

I will try it on word 2010 and Word 2003. I just tested it with fewer documents and in Word 2010 I combined and renumbered 100 documents with about 800 pages in the master document.

Thanks for your reply. Will report back in a few.

svo · #4 08-05-2015, 03:05 AM

Hi again Graham!

I implemented the Code you provided and had a couple of adjustments made to it. Word still will lock up after a number of combined documents. In 2003 this will happen earlier then in 2010. So I got around that by splitting my combined documents up into chunks, which can be set in the control document.

The code you provided speed up the whole combining by a factor of atleast 10 times. So a big thanks to this solution.

Code:

Sub CombineAll(sPath As String)
    Dim baseDoc As Document, sFile As String
    Dim oRng As Range
    ' Read the Size of the Splitter from the Bookmark in the control document
    Dim Splitter As Integer
    If ActiveDocument.Bookmarks.Exists("Splitter") Then
        On Error GoTo NoSplitter
        Splitter = Int(ActiveDocument.Bookmarks("Splitter").Range.Text)
    End If
    
    On Error GoTo err_Handler
    Set baseDoc = Application.Documents.Add
    sFile = Dir(sPath & "*.doc")
    ' Loop through the .doc in the output directory
    Dim DocSet As Integer: DocSet = 1
    Do While sFile <> ""
        ' Go to the end of the master document
        Set oRng = baseDoc.Range
        oRng.Collapse wdCollapseEnd
        ' add document set
        oRng.InsertFile sPath & sFile
        Set oRng = baseDoc.Range
        oRng.Collapse wdCollapseEnd
        ' insert section break at end of master document
        oRng.InsertBreak Type:=wdSectionBreakNextPage
        ' next file
        sFile = Dir
        DoEvents
        ' splitm up and re-number pages
        If DocSet > 1 And DocSet Mod Splitter = 0 Then
            RebuildNumbering
            ActiveDocument.SaveAs (sPath & DocSet & "_Teildokument.doc")
            ' open a new document when splitted 
            Set baseDoc = Application.Documents.Add
        End If
        DocSet = DocSet + 1
    Loop
    
lbl_Exit:
    ' Re-number the last document
    RebuildNumbering
    Debug.Print "Stitching Process complete"
    Set baseDoc = Nothing
    Set oRng = Nothing
    MsgBox "Fertig"
    Exit Sub
NoSplitter:
    MsgBox "Aufsplittungswert in Steuerdokument nicht gesetzt (1 < Wert < 51 && Lesezeichen auf Wert)"
    Set baseDoc = Nothing
    Set oRang = Nothing
    End
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
End Sub

Sub RebuildNumbering()
    ' re-number pages
    Dim sc As Integer: sc = ActiveDocument.Sections.Count
    For S = 1 To sc
        ' process= unlink from previous section, reset page numbers neustarten am Sektionsbeginn
        ActiveDocument.Sections(S).Footers(wdHeaderFooterFirstPage).LinkToPrevious = False
        With ActiveDocument.Sections(S).Footers(wdHeaderFooterFirstPage)
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.NumberStyle = wdPageNumberStyleArabic
            .PageNumbers.StartingNumber = 1
        End With
    Next S
    Debug.Print "Renumbering Done"
End Sub

I also now use the InsertFile now on the sub workflow for inserting mailmerge documents in my document set.

Thanks for sharing and helping me out. Me and my clients are really happy with the result

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Use multiple style sets in the same Word document (depending on which section the style is in)	Ricyteach	Word VBA	6	03-09-2015 07:11 PM
Macro for Combining Multiple Word Files Together Into One Document	rsrasc	Word VBA	2	10-31-2014 07:58 AM
Hidden page breaks and section breaks	jrasicmark	Word	3	06-02-2014 11:28 PM
Insert section breaks in a protected document	MS help	Word	2	03-09-2014 05:27 PM
Deleted Section Breaks Changes Page Breaks	Brantnshellie	Word	0	02-01-2009 09:22 PM