Determining merge order

[jpb103]

Hey fellas,

I've got a macro that grabs the data from the first table in every .docm file in a network folder, and then stitches all the data together into one table. It works fine, the problem I'm having is in determining in what order the files in this folder are opened. At the moment it seems to be random, though I know this cannot be the case. The files are named to reflect their position in the merged document (i.e. "A) Health and Safety", "B) Environment", etc...). I would think it would open them in alphabetical sequence (A, B, C, and so on), but it does not. The current order is (D, C, A, B, F, K, B, E, J ,G, L, C, I, H, C, B) keeping in mind that there are three B files and three C files whos inside order does not matter. Code follows:

Sub GetJournalData()
'///////////////////////////////////////////////////////////////////////////////////
'/////This function stitches together the data from the first table in all .docm////
'///////////////////////files in the listed directory.//////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////
    Dim Target As Word.Document
    Dim Source As Word.Document
    Dim RowTarget As Row
    Dim RowCount As Integer
    Dim iCounter As Integer
    Dim Folder As String
    Dim File As String
    'Set current document as Source file
    Set Source = ActiveDocument
    'Clear table of previous data, if it exists
    Do While Source.Tables(1).Rows.Count > 2
        Source.Tables(1).Rows.Last.Delete
    Loop
    'Set target folder
    Folder = "\\SharePoint@Port\teamsites\subsite\subsite\site\library\"
    'Find any and all .docm files in target folder
    File = Dir(Folder & "\*.docm")
    'Loop while there are still files to process
    Do While File <> ""
        'Open target and set Target variable
        Documents.Open FileName:=Folder & File
        Set Target = ActiveDocument
        RowCount = Target.Tables(1).Rows.Count
        For iCounter = 3 To RowCount
            'Add row and set elements
            Set RowTarget = Source.Tables(1).Rows.Add
            RowTarget.Cells(1).Range.Text = Target.Tables(1).Rows(iCounter).Cells(1).Range.Text
            RowTarget.Cells(2).Range.Text = Target.Tables(1).Rows(iCounter).Cells(2).Range.Text
            RowTarget.Cells(3).Range.Text = Target.Name
            RowTarget.Cells(4).Range.Text = Target.BuiltInDocumentProperties("Last Save Time")
        Next iCounter
        'Close target file
        Target.Close savechanges:=False
        File = Dir
    Loop
'//////////////////END//////////////////////////////////////////////////////////
End Sub

The apparent order does not appear to conincide with any property of the file (created date/time, last modified date/time, size, etc..). Any ideas, Word VBA community?

[gmaxey]

DIR won't return files in alphabetical order. You can try filesystemobject:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oFSO As FileSystemObject
Dim oFolder As Folder
Dim oFile As File
  Set oFSO = New FileSystemObject
  Set oFolder = oFSO.GetFolder("Your folder path")
  For Each oFile In oFolder.Files
    Debug.Print oFile.Name
  Next oFile
  
  
End Sub

[macropod]

Originally Posted by gmaxey

DIR won't return files in alphabetical order.

It does for me. Indeed, that seems to be the only order in which it returns files.

[gmaxey]

Paul,

I misspoke. My experience is that DIR can't guarantee files are returned in alphabetically order. I've experience it before and from what little I've read (via Google search) there isn't much that can be done about it.

Sorry for sounding dogmatic.

[macropod]

Does using FileSystemObject guarantee the sort order? Another way of handling this, without resorting to FileSystemObject, would be to use:

    Dim FileArray() As String
    Dim i As Long
    'Loop while there are still files to process
    Do While File <> ""
        i = i + 1
        ReDim Preserve FileArray(i)
        FileArray(i) = File
        File = Dir
    Loop
    WordBasic.SortArray FileArray
    For i = 1 To UBound(FileArray)
        Set Target = Documents.Open(FileName:=Folder & FileArray(i), AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
...
    Next

[gmaxey]

Paul,

I really don't know if FileSytemObject guarantees order or not. It always has for me. However, since I apparently have no idea what I am talking about here, I'm going to withdraw from the field before you bury me ;-)
.

[jpb103]

Thanks guys, I'll try these solutions out today.

[jpb103]

Solved. I used a quicksort algorithm though. Code follows:

'///////////////////////////////////////////////////////////////////////////////////
'/////This function stitches together the data from the first table in all /////////
'///////////////////////files in the listed directory.//////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////
Sub GetJournalData()
    Dim Target As Word.Document
    Dim Source As Word.Document
    Dim RowTarget As Row
    Dim RowCount As Integer
    Dim iCounter As Integer
    Dim Folder As String
    Dim File As String
    Dim FileArray() As String
    Dim i As Long
    'Set current document as Source file
    Set Source = ActiveDocument
    'Clear table of previous data, if it exists
    Do While Source.Tables(1).Rows.Count > 2
        Source.Tables(1).Rows.Last.Delete
    Loop
    'Set UNC folder path
    Folder = "\\SharePointsite@Port#\teamsite\site\library\"
    File = Dir(Folder)
    'Load file array
    Do While File <> ""
        i = i + 1
        ReDim Preserve FileArray(i)
        FileArray(i) = File
        File = Dir
    Loop
    'Sort file array alphabetically with quicksort algorithm
    Call QuickSort(FileArray, LBound(FileArray), UBound(FileArray))
    'Cycle through array, opening files and grabbing data
    For i = 1 To UBound(FileArray)
        Set Target = Documents.Open(FileName:=Folder & FileArray(i), Addtorecentfiles:=False, Visible:=False, ReadOnly:=True)
        RowCount = Target.Tables(1).Rows.Count
        For iCounter = 3 To RowCount
            Set RowTarget = Source.Tables(1).Rows.Add
            RowTarget.Cells(1).Range.Text = Target.Tables(1).Rows(iCounter).Cells(1).Range.Text
            RowTarget.Cells(2).Range.Text = Target.Tables(1).Rows(iCounter).Cells(2).Range.Text
            RowTarget.Cells(3).Range.Text = Target.Name
            RowTarget.Cells(4).Range.Text = Target.BuiltInDocumentProperties("Last Save Time")
        Next iCounter
        Target.Close savechanges:=False
    Next
End Sub
'///////////////////////////////////////END/////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////
'//////This function sorts the passed array based on the start and end points///////
'///////////////////////////////////////////////////////////////////////////////////
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long
    'Set initial bounds
    tmpLow = inLow
    tmpHi = inHi
    'Calculate pivot
    pivot = vArray((inLow + inHi) \ 2)
    'Loop while lower bound is not higher than upper bound
    While (tmpLow <= tmpHi)
        'Increment lower bound loop
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend
        'Decrement upper bound loop
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend
        'Sort items
        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
    'Recursive function calls
    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
'///////////////////////////////////////END/////////////////////////////////////////

Special thanks to Paul and Greg for the help on this one!