Loop through Dir and open files alphabetically

[Khardin]

Hello,

I have a macro which I have been using to loop through all files in the directory which contains my spreadsheet with the analysis macro. The macro works perfectly, except for the fact that I just discovered that using Dir does not return files in alphabetical or file system order, but in the order they are stored on the disk (ie: random). Unfortunately, order is essential for me, so I have been searching around and found a series of functions which loads file names into an array and sorts them, returning the sorted array. Due to my inability to properly implement this, I have created a simple version of my macro with my attempt to implement the functions. Any help/suggestions on how I can make the implementation work are much appreciated. Currently the macro does not run at all if I try to call the SortedFiles function.

This is the simplified version of my macro, it opens the spreadsheet and copies it Range("A1") to the analysis sheet which is titled Z_Test.xlsm, then loads the next file and copies A1 to the next empty row in Z_Test.xlsm.

Sub Test()

Application.ScreenUpdating = False

Dim OrginialFile
OriginalFile = Application.ActiveWorkbook.Name

Dim StartColumn As Integer
Dim EndColumn As Integer
Dim LastRow
Dim MyFile As String
Dim Mypath



'Change directory to actual directory
Mypath = ActiveWorkbook.Path & "\"

ChDir (Mypath)

'Run SortedFiles Function to return sorted array of files
SortedFiles (Mypath)

'Set MyFile variable to the sorted array of files
MyFile = files

Do While Len(files) > 0
'
If MyFile = "Z_Test.xlsm" Then

Dim fileName As String
fileName = Mypath & "_Summary" & ".xlsx"
ActiveWorkbook.SaveAs fileName:=fileName, FileFormat:=51
'
'

Application.DisplayAlerts = False
Application.ScreenUpdating = True


Exit Sub
End If
''
''
Workbooks.Open fileName:=MyFile
Sheets("Sheet1").Select
Range("A1").Copy


Windows(OriginalFile).Activate
Sheets("Sheet1").Select
'define first and last column of the range
StartColumn = 1
EndColumn = 2

LastRow = FindLastRow(StartColumn, EndColumn) 'call the function FindLastRow and return the value to the variable LastRow
'MsgBox "Last row is " & LastRow 'show and tell
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(LastRow, 1), Cells(LastRow, 2)).Offset(2)
Application.CutCopyMode = True

Windows(MyFile).Activate
Workbooks.Close

MyFile = Dir

Loop


End Sub

Function FindLastRow(iColI As Integer, iColN As Integer) As Long
    Dim iRowN As Long
    Dim iRowI As Long
    'Loop thorugh the columns
    For i = iColI To iColN
        'Define each columns' last row
        iRowI = Cells(Rows.Count, i).End(xlUp).Row
        'if last row is larger than in the previous column, save row number to iRowI
        If iRowI > iRowN Then iRowN = iRowI
    Next i
    FindLastRow = iRowN
End Function

Private Function SortedFiles(ByVal dir_path As String, _
    Optional ByVal exclude_self As Boolean = True, Optional _
    ByVal exclude_parent As Boolean = True) As String()
Dim num_files As Integer
Dim files() As String
Dim file_name As String

    file_name = Dir$(dir_path)
    Do While Len(file_name) > 0
        ' See if we should skip this file.
        If Not _
            (exclude_self And file_name = ".") Or _
            (exclude_parent And file_name = "..") _
        Then
            ' Save the file.
            num_files = num_files + 1
            ReDim Preserve files(1 To num_files)
            files(num_files) = file_name
        End If

        ' Get the next file.
        file_name = Dir$()
    Loop

    ' Sort the list of files.
    Quicksort files, 1, num_files

    ' Return the list.
    SortedFiles = files
End Function

Private Sub Quicksort(list() As String, ByVal min As Long, _
    ByVal max As Long)
Dim mid_value As String
Dim hi As Long
Dim lo As Long
Dim i As Long

    ' If there is 0 or 1 item in the list,
    ' this sublist is sorted.
    If min >= max Then Exit Sub

    ' Pick a dividing value.
    i = Int((max - min + 1) * Rnd + min)
    mid_value = list(i)

    ' Swap the dividing value to the front.
    list(i) = list(min)

    lo = min
    hi = max
    Do
        ' Look down from hi for a value < mid_value.
        Do While list(hi) >= mid_value
            hi = hi - 1
            If hi <= lo Then Exit Do
        Loop
        If hi <= lo Then
            list(lo) = mid_value
            Exit Do
        End If

        ' Swap the lo and hi values.
        list(lo) = list(hi)

        ' Look up from lo for a value >= mid_value.
        lo = lo + 1
        Do While list(lo) < mid_value
            lo = lo + 1
            If lo >= hi Then Exit Do
        Loop
        If lo >= hi Then
            lo = hi
            list(hi) = mid_value
            Exit Do
        End If

        ' Swap the lo and hi values.
        list(hi) = list(lo)
    Loop

    ' Sort the two sublists.
    Quicksort list, min, lo - 1
    Quicksort list, lo + 1, max
End Sub

 

[RickXL]

Hi,

I am not exactly sure what your macro is doing but I hope mine is sufficiently similar that you can make use of some of the ideas.

It gets a list of files using Dir.
It sorts them into alphabetical order.
Then it opens each one in turn.
It copies A1 from the first worksheet
Finds the last row in the summary worksheet
Pastes the data into it.
This is repeated for every file in the list.

In stead of writing a sorting program I used an ArrayList. That has a Sort method. Basically, you keep adding elements to the array and then you ask it to sort them into order. I exclude the name of the current file from that list so it will not be processed later. I have used "Early Binding" so you will need to set a reference to mscorlib.dll. In the VB Editor go to Tools--> References then select mscorlib.dll from the list.

Instead of finding the last row in one column and then the last row in the next column I used a line of code that would do both at once. You can extend it to any number of columns.

Sub fileProcess()

    'Requires: Tools--> References--> mscorlib.dll
    Dim alFiles As New ArrayList
    Dim varFile As Variant
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim strPath As String
    Dim lr As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")   ' Sheet name to log data
    Set alFiles = New ArrayList
    
    ' Load files into an ArrayList - excluding this file
    strPath = ThisWorkbook.Path & "\"
    varFile = Dir(strPath)
    Do While varFile <> ""
        If varFile <> ThisWorkbook.Name Then alFiles.Add varFile
        varFile = Dir
    Loop
    
    ' Sort the list into order
    alFiles.Sort

    ' Process each file in turn
    For Each varFile In alFiles
        ' Open workbook
        Application.EnableEvents = False
        Set WB = Workbooks.Open(strPath & varFile, UpdateLinks:=False, ReadOnly:=True)
        Application.EnableEvents = True
        ' Copy value(s)
        WB.Worksheets(1).Range("A1").Copy
        ' Close the workbook
        WB.Close savechanges:=False
        ' Find the last row
        lr = ws.Columns("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        ' Write the data
        ws.Paste Destination:=ws.Range("A1").Offset(lr, 0)
    Next

End Sub