0

Below is my code that reads in all excel files from a folder / copies their first sheet into a new excel file. It's working fine so far. But now I want to make it do exactly the same thing, but just starting with the most recently modified excel file in the folder, and continuing with the second most recent excel file in the folder and so on. Then, at some point, it should stop, once it encounters a file that's bigger than 450KB (I already implemented that feature).

So, all I want, is the code to work through the files in the folder in order of the DateLastModified.

My ideas so far:

  1. Use an array to store paths of all files in the folder / directory; then sort the elements in that array; then use the array as a source for my Do While Loop.
  2. have the program copy all the paths and DateLastModifieds of the files in the folder / directory into an Excel sheet; sort it there and use that as the source for my Do While Loop.

Problems:

  1. I'm a little overwhelmed with this as I've never worked with arrays before. It seems possible though, maybe you could help me on implementing this in my specific case? For example, wouldn't jindons answer work in my case? https://www.ozgrid.com/forum/index.php?thread/102275-open-the-fiels-in-folder-based-on-last-modified-date/

  2. This seems plausible, but I'd prefer the first method, since it will make for a faster program.

Sub readsheetsfromseveralfiles()
   Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sDatei As String
   Dim fsize As Long

     Application.ScreenUpdating = False
     Application.DisplayAlerts = False

     Set oTargetBook = ActiveWorkbook

     sDatei = Dir$(sPfad & "*.xl*") 'Alle Excel Dateien

'QUESTION: I want the program to do the following process, but starting with the most recent
'file (meaning the latest by DateLastModified). One Idea: Use Array here to put paths of all files
'in, and sort the array, then pull paths from the sorted array? 

     sPfad = "D:\Path\folderwithfiles\"

     Do While sDatei <> ""

        fsize = FileLen(sPfad & "\" & sDatei)

         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen

         oSourceBook.Sheets(1).Copy after:=oTargetBook.Sheets(oTargetBook.Sheets.Count)

         On Error Resume Next

         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = sDatei

         'reset possible errors
         If Err.Number <> 0 Then
             Err.Number = 0
             Err.Clear
         End If
         On Error GoTo 0

         'close file and start next round
         oSourceBook.Close False 'don't save


         If fsize > 450000 Then Exit Do     'if the last file has exceeded this file size, stop the import process

         'next file
         sDatei = Dir()
     Loop

     Application.ScreenUpdating = True
     Application.DisplayAlerts = True

     Sheets("Auswertung").Select    'go back to first page
     Range("A1").Select

     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub
´´´
fecotin
  • 3
  • 1
  • 4
  • see: https://stackoverflow.com/questions/4282940/does-dir-make-any-guarantee-on-the-order-of-files-returned – Scott Craner Mar 25 '20 at 14:13
  • We are not going to write the array loop for you. Please make an attempt and come back when you hit a block or and error that you cannot overcome. Show a [MCVE] and ask a specific question on how to overcome the issue. – Scott Craner Mar 25 '20 at 14:15
  • @ScottCraner Ok, but so you're saying that an Array loop would be the best way of doing this, right? Would this Quicksort algorithm that's mentioned in the link you provided also work? – fecotin Mar 25 '20 at 15:44
  • Arrays are the best and quickest way to go. As to the quicksort, it is a good place to start. If you google `dir vba sort by datelastmodified` you may find other algorithms already created. – Scott Craner Mar 25 '20 at 15:46

1 Answers1

0

You could use excel to do the sorting. Create a Log sheet to hold filename, time and size from Dir, sort it and then scan it for the copying,

Sub readsheetsfromseveralfiles()

    Const FOLDER = "D:\Path\folderwithfiles\"
    Const SHT_LOG = "Sheet3"
    Const MAX_SIZE = 450000

    Dim wb As Workbook, wsLog As Worksheet
    Dim wbSource As Workbook
    Dim filename As String, absfile As String, t0 As Single
    Dim i As Long, n As Long

    Set wb = ThisWorkbook
    Set wsLog = wb.Sheets(SHT_LOG)

    filename = Dir$(FOLDER & "*.xl*") 'Alle Excel Dateien

    ' compile log sheet
    t0 = Timer
    i = 0
    With wsLog
       .Cells.Clear
        Do While Len(filename) > 0
            absfile = FOLDER & filename

            ' write to sheet name, timestamp ,size
            i = i + 1
            .Cells(i, 1) = filename
            .Cells(i, 2) = Format(FileDateTime(absfile), "yyyy-mm-dd hh:mm:ss")
            .Cells(i, 3) = FileLen(absfile)

            ' next file
            filename = Dir()
        Loop

        ' sort by time desc
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("B1:B" & i), _
                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange Range("A1:C" & i)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Columns("A:C").AutoFit
    End With

    ' scan Log sheet copying files
    i = 1
    n = wb.Sheets.Count ' count existing sheets
    Do While Len(wsLog.Cells(i, 1)) > 0

        ' open wb and copy sheet 1
        filename = wsLog.Cells(i, 1)
        Set wbSource = Workbooks.Open(FOLDER & filename, False, True) 'nur lesend ?ffnen
        wbSource.Sheets(1).Copy after:=wb.Sheets(n)
        n = n + 1
        wsLog.Cells(i, 4) = n ' record sheet no

        'rename
        On Error Resume Next
        wb.Sheets(n).Name = filename

        If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
            wsLog.Cells(i, 4).Interior.Color = vbRed
        Else
            wsLog.Cells(i, 4).Interior.Color = vbGreen
        End If
        On Error GoTo 0

        'close file and start next round
         wbSource.Close False 'don't save

        ' check size
        If wsLog.Cells(i, 3) > MAX_SIZE Then
            Exit Do
        End If
        i = i + 1
    Loop

    MsgBox i - 1 & " files copied", vbInformation, "Competed in " & Int(Timer - t0) & " secs"
    wsLog.Activate
    wsLog.Range("A1").Select

End Sub


CDP1802
  • 13,871
  • 2
  • 7
  • 17