Combine documents from folder - vba

Question

I have a document with several letters separated with section breaks.
What I want to do is to break the document into several ones containing X number of letters (without manually selecting them).
What I have done is to separate it into individual letters with one macro (BreakOnSection), and then combine them with another one (MergeMultiDocsIntoOne) that open a file browser and allows me to select the files I want manually. Below are the macros.
Main Question: If the main document is divided into, let's say, 100 smaller documents, is it possible to modify the second macro, so it selects automatically 10 of them from a folder, merges/combines them creating a new document, and then goes on with another batch of 10, and so on?
First macro:
Sub BreakOnSection()
'Criteria for moving through the document by section.
Application.Browser.Target = wdBrowseSection
'For i = 1 To ((ActiveDocument.Sections.Count) - 1)
For i = 1 To ActiveDocument.Sections.Count
'Copy the whole section
ActiveDocument.Bookmarks("\Section").Range.Copy
'Create a new document to paste text from the clipboard.
Documents.Add
Selection.Paste
'Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
ChangeFileOpenDirectory "C:\Users\MyUser\Desktop\MyFolder"
DocNum = DocNum + 1
ActiveDocument.SaveAs Filename:="letter_" & DocNum & ".docx"
ActiveDocument.Close
'Move the selection to the next section
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
'ActiveDocument.Close savechanges:=wdSaveChanges
End Sub
Second macro:
Sub MergeMultiDocsIntoOne()
Dim dlgFile As FileDialog
Dim nTotalFiles As Integer
Dim nEachSelectedFile As Integer
Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)
With dlgFile
.AllowMultiSelect = True
If .Show <> -1 Then
Exit Sub
Else
nTotalFiles = .SelectedItems.Count
End If
End With
For nEachSelectedFile = 1 To nTotalFiles
Selection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
If nEachSelectedFile < nTotalFiles Then
Selection.InsertBreak Type:=wdPageBreak
Else
If nEachSelectedFile = nTotalFiles Then
Exit Sub
End If
End If
Next nEachSelectedFile
End Sub

Answer 1

Instead of breaking all the Sections into separate documents before recombining them, you'd do far better to simply split the original document into however multi-Section blocks you need. The following code will split any multi-Section document that you might want to break into equal Section counts:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per output document?", "Split By Sections", 1)
With ActiveDocument
' Process each Section
For i = 1 To .Sections.Count - 1 Step j
With .Sections(i)
'*****
' Get the 1st paragraph
Set Rng = .Range.Paragraphs(1).Range
With Rng
' Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & StrTxt
'*****
' Get the whole Section
Set Rng = .Range
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
' Copy the range
.Copy
End With
End With
' Create the output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
' Replicate the headers & footers
For Each HdFt In Rng.Sections(j).Headers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Word document and PDF output are both catered for.
As coded, it is assumed the output filename consists of the first paragraph in each group of Sections. If not, you could use a different range or replace all of the content between the ***** strings with code like:
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & (i + j - 1) / j