![]() |
#4
|
|||
|
|||
![]()
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 Thanks for sharing and helping me out. Me and my clients are really happy with the result |
Tags |
combine documents, page numbering |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
Ricyteach | Word VBA | 6 | 03-09-2015 07:11 PM |
![]() |
rsrasc | Word VBA | 2 | 10-31-2014 07:58 AM |
![]() |
jrasicmark | Word | 3 | 06-02-2014 11:28 PM |
![]() |
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 |