mergefiles.vb

Sub MergeDocumentsWithHeadings()
    Dim objDoc As Document
    Dim objRange As Range
    Dim strFolder As String
    Dim strFileName As String
    Dim strHeader As String
    Dim dtCreated As Date
    Dim headingLevel As Integer
    Dim chapters() As Variant
    Dim chapter As Variant
    
    ' Set the folder path where the documents are located
    strFolder = "C:\Users\Steve\" 'REPLACE WITH YOUR FOLDER
    
    ' Create a new document to merge the documents into
    Set objDoc = Documents.Add
    
    ' Get the range of the new document
    Set objRange = objDoc.Range
    
    ' Set the initial heading level
    headingLevel = 1
    
    ' Initialize the array to store chapters/documents
    ReDim chapters(1 To 1)
    
    ' Loop through each file in the folder
    strFileName = Dir(strFolder & "*.docx")
    Do While strFileName <> ""
        ' Open the document
        Documents.Open strFolder & strFileName
        
        ' Get the creation date of the document
        dtCreated = Documents(strFileName).BuiltInDocumentProperties("Creation Date").Value
        
        ' Add the document information to the array
        ReDim Preserve chapters(1 To UBound(chapters) + 1)
        chapters(UBound(chapters) - 1) = Array(strFileName, dtCreated)
        
        ' Close the opened document
        Documents(strFileName).Close False
        
        ' Move to the next file
        strFileName = Dir
    Loop
    
    ' Sort the chapters array by creation date in descending order
    SortChaptersByDate chapters
    
    ' Loop through the sorted chapters array
For i = LBound(chapters) To UBound(chapters) - 1
    strFileName = chapters(i)(0)
    dtCreated = chapters(i)(1)
    Documents.Open strFolder & strFileName
    
    ' Copy the contents of the document and paste into the new document
    Documents(strFileName).Content.Copy
    
    Set objRange = objDoc.Range
    objRange.Collapse wdCollapseEnd
    
    If i <> 0 Then
        ' Add a page break before the heading
        objRange.InsertBreak wdPageBreak
    End If
    
    ' Add a heading to the merged document
    objRange.InsertBefore "Chapter " & headingLevel & ": " & strFileName & vbCrLf
    objRange.Style = wdStyleHeading1
    objRange.Collapse wdCollapseEnd
    
    ' Retrieve the creation date of the document
    With objRange
        .Text = "Creation Date: " & Format(dtCreated, "mm/dd/yyyy") & vbCrLf
        .Font.Bold = True
    End With
    objRange.Collapse wdCollapseEnd
    objRange.PasteAndFormat wdPasteDefault
    
    ' Move the range to the end of the merged document
    objRange.Collapse wdCollapseEnd

    ' Increment the heading level
    headingLevel = headingLevel + 1
    
    ' Close the opened document
    Documents(strFileName).Close False
Next i

    
    ' Save the merged document
    objDoc.SaveAs2 "C:\Users\Steve\MergedDocument.docx" 'REPLACE WITH YOUR FOLDER
    
    ' Close the merged document
    objDoc.Close
    
    ' Clean up
    Set objDoc = Nothing
    Set objRange = Nothing
    Erase chapters
    
    MsgBox "Merge complete!"
End Sub


Sub SortChaptersByDate(ByRef chapters() As Variant)
    Dim i As Integer
    Dim j As Integer
    Dim temp As Variant
    
    For i = 1 To UBound(chapters) - 1
        For j = i + 1 To UBound(chapters) - 1
            If CDate(chapters(i)(1)) < CDate(chapters(j)(1)) Then
                temp = chapters(i)
                chapters(i) = chapters(j)
                chapters(j) = temp
            End If
        Next j
    Next i
End Sub