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