Not able to merge many Word docs in right order to one using Macros?

Question

I am trying to merge many word documents into one word document using VBA Macros. I wrote the following code to do this task

Sub MergeDocs()
    Dim rng As Range
    Dim MainDoc As Document
    Dim strFile As String, strFolder As String
    Dim Count As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Pick your folder"
        .AllowMultiSelect = False
        If .Show Then
            strFolder = .SelectedItems(1) & Application.PathSeparator
        Else
            Exit Sub
        End If
    End With
    Set MainDoc = Documents.Add
    strFile = Dir$(strFolder & "*.doc") '
    Count = 0
    Do Until strFile = ""
        Count = Count + 1
        Set rng = MainDoc.Range
        With rng
            .Collapse 0
            If Count > 1 Then
                .InsertBreak 2
                .End = MainDoc.Range.End
                .Collapse 0
            End If
            .InsertFile strFolder & strFile
        End With
        strFile = Dir$()
    Loop
    MsgBox ("Files are merged")
lbl_Exit:
    Exit Sub

This does it's job very well except the order of the docs is not in correct way.

So here is the example how it's working. If i merge the docs as doc1,doc2,doc3,doc4 into one doc, then this macro merges them all but in random order as doc3,doc2,doc4,doc1 where as i want the docs to be in order as doc1,doc2,doc3,doc4.

Could anyone please try it and help me to get this resolved as i am not having much exposure on VB Macros in MS-Word.

Appreciate your help.

Thanks

This might help: http://stackoverflow.com/questions/4282940/does-dir-make-any-guarantee-on-the-order-of-files-returned — Munir, Nov 21 '15 at 19:40

score 0 · Answer 1 · answered Nov 21 '15 at 22:28

I have got the solution to my problem and posting my code here for the people facing similar issue

Sub MergeDocs()

' Macro for Merging of Many Word Documents into a Single one'

'   Variable Declaration'
Dim rng As Range
Dim MainDoc As Document
Dim AllDocs As Variant
Dim strFile As String, strFolder As String
Dim Count As Long

'   Assigning a value for further use in loop'
Count = 1

'   Ask User to select the Folder containing word documents to be merged'
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Pick the To_Be_Merged Documents Folder"
    .AllowMultiSelect = False
    If .Show Then
        strFolder = .SelectedItems(1) & Application.PathSeparator
    Else
        Exit Sub
    End If
End With

Set MainDoc = Documents.Add

'   Calling GetFileList Function  to get all the documents from folder selected'
AllDocs = GetFileList(strFolder & "*.doc")

'   Calling QuickSort Subroutine to sort the array in ascending order'
If IsArray(AllDocs) Then
    Call QuickSort(AllDocs, LBound(AllDocs), UBound(AllDocs))
End If

Select Case IsArray(AllDocs)

    Case True
        MsgBox UBound(AllDocs) & " documents found"
        For Index = LBound(AllDocs) To UBound(AllDocs)
            strFile = AllDocs(Index)
            Count = Count + 1
            Set rng = MainDoc.Range
            With rng
                .Collapse 0
                If Count > 2 Then
                    .InsertBreak 2
                    .End = MainDoc.Range.End
                    .Collapse 0
                End If
                    .InsertFile strFolder & strFile
            End With
        Next Index

    Case False
        MsgBox "No File Found"

End Select
    MsgBox ("Your documents have been merged successfully")

lbl_Exit:
    Exit Sub

End Sub

' Returns an array of filenames that match FileSpec'

Function GetFileList(FileSpec As String) As Variant

'   Variables declaration'
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

'   Loop until no more matching files are found
Do While FileName <> ""
    FileCount = FileCount + 1
    ReDim Preserve FileArray(1 To FileCount)
    FileArray(FileCount) = FileName
    FileName = Dir()
Loop
GetFileList = FileArray
Exit Function

'   Error handler

NoFilesFound:
GetFileList = False
End Function

' Returns array sorted in ascending order'

Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

' Variables declaration'

Dim pivot   As Variant
Dim tmpSwap As Variant
Dim tmpLow  As Long
Dim tmpHi   As Long

tmpLow = inLow
tmpHi = inHi

pivot = vArray((inLow + inHi) \ 2)

While (tmpLow <= tmpHi)

    While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
    Wend

    While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
    Wend

    If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
    End If

Wend

If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

lbl_Exit:
Exit Sub

End Sub

Thanks

Not able to merge many Word docs in right order to one using Macros?

1 Answers1