Using VBA to list and sort folders and files in Excel

carcharoth2554 · Apr 24, 2013

Hi guys,

Excel 2010 in Win 7 64bit

I am adapting some code I found in another thread to first list all files found in a target directory and then want it to do some basic sorting. All I am really stuck on is getting the sub ListFilesInFolder() to list the different sub-directories in separate columns; at the moment it reads them all into the same column. I have tried a few approaches on this but cannot figure where I should be putting my column count increase (Dim t). Please see attached code.

Another problem I have had with this code is how slow it is. I have tried adding Application.ScreenUpdating modifiers which cut the processing time in half but for 300+ files I am still looking at 41 seconds. Is there anything that can be done to speed this up or is it just a very large amount of data it is having to handle?

I appreciate any input as you guys have been great in the past.

Thanks!

Code:

Sub GetDirectory()
    Application.Calculation = xlCalculationManual
    Dim CheckPath As String
    Dim Msg As Byte
    Dim Drilldown As Boolean
    CheckPath = "O:\Timesheets and Forms\2013 Timesheets\Test Folder"
    Worksheets("Register").Range("A1:H999").ClearContents
    If CheckPath = "" Then
        MsgBox "No folder was selected.  Procedure aborted.", vbExclamation, "StaffSmart Add-In"
        Exit Sub
    End If
    Msg = MsgBox("Do you want to list all files in subfolders, too?", _
        vbInformation + vbYesNo, "Drill-Down")
    If Msg = vbYes Then Drilldown = True Else Drilldown = False
    ' add headers
    Application.ScreenUpdating = False
    With Range("A1")
        .Value = CheckPath
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Folder:"
    Range("A3:H3").Font.Bold = True
    ListFilesInFolder CheckPath, Drilldown
    ' list all files included subfolders
    Range("a4").Select
    ActiveWindow.FreezePanes = True
    Range("a3").Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlYes
    Range("a3").Select
    ActiveWindow.LargeScroll Up:=100
    Application.ScreenUpdating = True
    MsgBox "Done", vbOKOnly, "StaffSmart Add-In"

End Sub
Private Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim SourceFolder As Object 'Scripting.Folder
    Dim SubFolder As Object 'Scripting.Folder
    Dim FileItem As Object 'Scripting.File
    Dim r As Integer
    Dim t As Integer
    Dim c As Integer
    Dim strAddress As String
    Dim strDisplayText As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    t = 1

' If "descendant" folders also get their files listed, then sub calls itself recursively
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
            t = t + 1
        Next SubFolder
    End If

    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(r, t).Value = FileItem.Name
        Worksheets("Register").Hyperlinks.Add Anchor:=Cells(r, t), Address:=FileItem.ParentFolder.Path & "\" & FileItem.Name
        r = r + 1 ' next row number
    Next FileItem
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

carcharoth2554 · May 3, 2013

I just replaced with the whole code as per your suggestion. I first tested on a small test folder containing around 30 pdf files; smooth running, about 9 secs processing time. When I opened this up to a larger directory however it processed for around 24 seconds and then hit runtime error 9 and pointed me to 'ReDim Preserve aFD(UBound(aFD, 1), UBound(aFD, 2) + 20)' on the debug.

This new code is now a little beyond my understanding so I am not sure what on earth it is complaining about.

The larger directory has 23 subs and a couple hundred assorted pdf and excel files.

I need to run for the day now but I would be very interested to hear you thoughts! I think I bit off more than I can chew with this particular function!

Thanks again!

sijpie · May 3, 2013

OK this should do the trick

 Dim t As Integer Dim CheckPath As String Dim aFD As Variant, aHypL As Variant Sub GetDirectory() Application.Calculation = xlCalculationManual Dim Msg As Byte, lR As Long, lC As Long Dim NewItem As Boolean, NewDir As Boolean Dim aOld As Variant Dim wsReg As Worksheet, rOut As Range CheckPath = "C:\Users\x01025047\Documents\_Videle\Stage 1\Locations" '"O:\Timesheets and Forms\2013 Timesheets\Test Folder" ' Worksheets("Register").Cells.ClearContents If CheckPath = "" Then MsgBox "No folder was selected. Procedure aborted.", vbExclamation, "StaffSmart Add-In" Exit Sub End If Application.ScreenUpdating = False Set wsReg = Sheets("Register") With wsReg Set rOut = .Range("A3").CurrentRegion ' header row of table ' load entire existing page in array If rOut.Cells.Count = 1 Then aOld = rOut.Resize(3, 3) ' arbitrary size to avoid crash Else aOld = rOut End If With .Range("A1") .Value = CheckPath .Font.Bold = True .Font.Size = 12 End With 'initialise column counter for the arrays t = 1 ' make filelist array and hyperlink array same size but a bit larger as aOld to start of with, _ so only needs to be resized for large number additional files or directories, as this is a pain ReDim aFD(1 To 500 + UBound(aOld, 1), 1 To 20 + UBound(aOld, 2)) ReDim aHypL(1 To 500 + UBound(aOld, 1), 1 To 20 + UBound(aOld, 2)) ListFilesInFolder CheckPath ' list all files included subfolders .Range("A3").Resize(1, .Range("A3").End(xlToRight).Column).Font.Bold = True ' print array to sheet Set rOut = .Range("a3").Resize(UBound(aFD, 1), UBound(aFD, 2)) rOut.Value = aFD ' set hyperlinks Set rOut = .Range("a3") For lC = 1 To UBound(aFD, 2) NewDir = False For lR = 1 To UBound(aFD, 1) ' check wich names need hyperlink renewed If Len(aFD(lR, lC)) Then 'only check if file If lR > UBound(aOld, 1) Or lC > UBound(aOld, 2) Then ' additional files outside old range NewItem = True ElseIf aOld(lR, lC) <> aFD(lR, lC) Then ' if name different NewItem = True If lR = 1 Then NewDir = True ' new directory ' NewDir is used to flag up that the directory is different ' so all links in column have to be renewed (there can be a same name file in two dirs) Else NewItem = False End If If (NewItem Or NewDir) And lR > 1 Then Worksheets("Register").Hyperlinks.Add Anchor:=rOut.Offset(lR - 1, lC - 1), Address:=aHypL(lR, lC) End If End If Next lR Next lC .Range("a4").Select ActiveWindow.FreezePanes = True .Range("a3").Sort Key1:=.Range("A4"), Order1:=xlAscending, Header:=xlYes .Range("a3").Select ActiveWindow.LargeScroll Up:=100 End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ' MsgBox "Done", vbOKOnly, "StaffSmart Add-In" End Sub Private Sub ListFilesInFolder(SourceFolderName As String) ' lists information about the files in SourceFolder ' example: ListFilesInFolder "C:\FolderName\", True Dim FSO As Object 'Scripting.FileSystemObject Dim SourceFolder As Object 'Scripting.Folder Dim SubFolder As Object 'Scripting.Folder Dim FileItem As Object 'Scripting.File Dim r As Long Dim strAddress As String Dim strDisplayText As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(SourceFolderName) r = 2 'first row for the file list For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path t = t + 1 If t > UBound(aFD, 2) Then ' redim aFD & HypL ' this can be done using Redim Preserve ' Add 20 columns for some reserve ReDim Preserve aFD(UBound(aFD, 1), UBound(aFD, 2) + 20) ReDim Preserve aHypL(UBound(aFD, 1), UBound(aFD, 2) + 20) End If Next SubFolder ' put subfolder name in first row aFD(1, t) = Right(SourceFolder.Path, Len(SourceFolder.Path) - Len(CheckPath)) If Len(aFD(1, t)) = 0 Then aFD(1, t) = "\" For Each FileItem In SourceFolder.Files ' display file properties aFD(r, t) = FileItem.Name aHypL(r, t) = FileItem.ParentFolder.Path & "\" & FileItem.Name r = r + 1 ' next row number If r > UBound(aFD, 1) Then ' redim aFD & aHypL, add 500 rows ' Redim Preserve cannot be used to change nr of rows ' so copy to temp arrays and then increase size and ' copy back Dim aTemp1 As Variant, aTemp2 As Variant Dim lR As Long, lC As Long ReDim aTemp1(1 To UBound(aFD, 1), 1 To UBound(aFD, 2)) ReDim aTemp2(1 To UBound(aFD, 1), 1 To UBound(aFD, 2)) For lR = 1 To UBound(aFD, 1) For lC = 1 To UBound(aFD, 2) aTemp1(lR, lC) = aFD(lR, lC) aTemp2(lR, lC) = aHypL(lR, lC) Next lC Next lR ReDim aFD(500 + UBound(aFD, 1), UBound(aFD, 2)) ReDim aHypL(500 + UBound(aFD, 1), UBound(aFD, 2)) For lR = 1 To UBound(aFD, 1) For lC = 1 To UBound(aFD, 2) aFD(lR, lC) = aTemp1(lR, lC) aHypL(lR, lC) = aTemp2(lR, lC) Next lC Next lR ReDim aTemp1(1, 1) ReDim aTemp2(1, 1) End If Next FileItem Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub

sijpie · May 3, 2013

OK, let me check out the issue with the redim. It should work, but I need to create myself some serious large directories

Shouldn't be too difficult. The code above will have the same issue. So let me sort it first.

It should run fine on smaller structures, and you can test the hyper linking and the speed of redoing it when a few files have been added.
2nd time around should run faster

sijpie · May 3, 2013

I think I have it sorted now. it was a bit sneaky, and it hasn't reappeared in a number of test I did subsequently. I also found a few other minor bugs....

I put a timer in the final product to see where it was using most and in what ratio. The four times shown (first msgbox is first time run, clear spreadsheet on 1500 files in 244 directories, on directory with 600 files, the 2nd msgbox is the same directory structure on a second run) are:

start-up, preparing arrays & ranges
filling arrays with file structure
printing to screen
setting hyperlinks

so as expected going through the tree takes most time, nearly 2 seconds on my harddrive. the rest is negligable

OK, here goes:

 Dim t As Integer Dim CheckPath As String Dim aFD As Variant, aHypL As Variant Sub GetDirectory() Application.Calculation = xlCalculationManual Dim Msg As Byte, lR As Long, lC As Long Dim NewItem As Boolean, NewDir As Boolean Dim aOld As Variant Dim wsReg As Worksheet, rOut As Range CheckPath = "O:\Timesheets and Forms\2013 Timesheets\Test Folder" If CheckPath = "" Then MsgBox "No folder was selected. Procedure aborted.", vbExclamation, "StaffSmart Add-In" Exit Sub End If Application.ScreenUpdating = False Set wsReg = Sheets("Register") With wsReg Set rOut = .Range("A3").CurrentRegion ' header row of table ' load entire existing page in array If rOut.Cells.Count = 1 Then aOld = rOut.Resize(3, 3) ' arbitrary size to avoid crash Else aOld = rOut End If With .Range("A1") .Value = CheckPath .Font.Bold = True .Font.Size = 12 End With 'initialise column counter for the arrays t = 1 ' make filelist array and hyperlink array same size but a bit larger as aOld to start of with, _ so only needs to be resized for large number additional files or directories, as this is a pain ReDim aFD(1 To 500 + UBound(aOld, 1), 1 To 20 + UBound(aOld, 2)) ReDim aHypL(1 To 500 + UBound(aOld, 1), 1 To 20 + UBound(aOld, 2)) ListFilesInFolder CheckPath ' list all files included subfolders .Range("A3").Resize(1, .Range("A3").End(xlToRight).Column).Font.Bold = True ' print array to sheet Set rOut = .Range("a3").Resize(UBound(aFD, 1), UBound(aFD, 2)) rOut.Value = aFD ' set hyperlinks Set rOut = .Range("a3") For lC = 1 To UBound(aFD, 2) NewDir = False For lR = 1 To UBound(aFD, 1) ' check wich names need hyperlink renewed If Len(aFD(lR, lC)) Then 'only check if file If lR > UBound(aOld, 1) Or lC > UBound(aOld, 2) Then ' additional files outside old range NewItem = True ElseIf aOld(lR, lC) <> aFD(lR, lC) Then ' if name different NewItem = True If lR = 1 Then NewDir = True ' new directory ' NewDir is used to flag up that the directory is different ' so all links in column have to be renewed (there can be a same name file in two dirs) Else NewItem = False End If If (NewItem Or NewDir) And lR > 1 Then Worksheets("Register").Hyperlinks.Add Anchor:=rOut.Offset(lR - 1, lC - 1), Address:=aHypL(lR, lC) End If ElseIf lR < UBound(aOld, 1) And lC < UBound(aOld, 2) Then ' check if less files in directory, delete hyperlinks If Len(aOld(lR, lC)) Then rOut.Offset(lR - 1, lC - 1).Resize(UBound(aOld, 1), 1).Clear Dim lRO As Long ' clear rest of column in aOld as we need to do this only once For lRO = lR To UBound(aOld, 1) aOld(lRO, lC) = "" Next lRO End If End If Next lR Next lC .Range("a4").Select ActiveWindow.FreezePanes = True .Range("a3").Sort Key1:=.Range("A4"), Order1:=xlAscending, Header:=xlYes .Range("a3").Select ActiveWindow.LargeScroll Up:=100 End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ' MsgBox "Done", vbOKOnly, "StaffSmart Add-In" End Sub Private Sub ListFilesInFolder(SourceFolderName As String) ' lists information about the files in SourceFolder ' example: ListFilesInFolder "C:\FolderName\", True Dim FSO As Object 'Scripting.FileSystemObject Dim SourceFolder As Object 'Scripting.Folder Dim SubFolder As Object 'Scripting.Folder Dim FileItem As Object 'Scripting.File Dim r As Long Dim strAddress As String Dim strDisplayText As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(SourceFolderName) r = 2 'first row for the file list For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.path t = t + 1 If t > UBound(aFD, 2) Then ' redim aFD & HypL ' this can be done using Redim Preserve ' Add 20 columns for some reserve ReDim Preserve aFD(1 To UBound(aFD, 1), 1 To (UBound(aFD, 2) + 20)) ReDim Preserve aHypL(1 To UBound(aHypL, 1), 1 To (UBound(aHypL, 2) + 20)) End If Next SubFolder ' put subfolder name in first row aFD(1, t) = Right(SourceFolder.path, Len(SourceFolder.path) - Len(CheckPath)) If Len(aFD(1, t)) = 0 Then aFD(1, t) = "\" For Each FileItem In SourceFolder.Files ' display file properties aFD(r, t) = FileItem.Name aHypL(r, t) = FileItem.ParentFolder.path & "\" & FileItem.Name r = r + 1 ' next row number If r > UBound(aFD, 1) Then ' redim aFD & aHypL, add 500 rows ' Redim Preserve cannot be used to change nr of rows ' so copy to temp arrays and then increase size and ' copy back Dim aTemp1 As Variant, aTemp2 As Variant Dim lR As Long, lC As Long ReDim aTemp1(1 To UBound(aFD, 1), 1 To UBound(aFD, 2)) ReDim aTemp2(1 To UBound(aFD, 1), 1 To UBound(aFD, 2)) For lR = 1 To UBound(aFD, 1) For lC = 1 To UBound(aFD, 2) aTemp1(lR, lC) = aFD(lR, lC) aTemp2(lR, lC) = aHypL(lR, lC) Next lC Next lR ReDim aFD(1 To (500 + UBound(aFD, 1)), 1 To UBound(aFD, 2)) ReDim aHypL(1 To UBound(aFD, 1), 1 To UBound(aFD, 2)) For lR = 1 To UBound(aTemp1, 1) For lC = 1 To UBound(aTemp1, 2) aFD(lR, lC) = aTemp1(lR, lC) aHypL(lR, lC) = aTemp2(lR, lC) Next lC Next lR ReDim aTemp1(1, 1) ReDim aTemp2(1, 1) End If Next FileItem Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub

carcharoth2554 · May 8, 2013

Edited: Ignore this, oddly thread did not update for me until I posted!

carcharoth2554 · May 8, 2013

Sweet mother, it works! IIIT'SSSSS ALIIIIIVE!!!!!!!

Stunning job, runtime is slightly longer than yours as expected due to the shared drive but it does all I need it to.

Thank you so much!

Using VBA to list and sort folders and files in Excel

carcharoth2554

New Member

carcharoth2554

New Member

sijpie

Well-known Member

sijpie

Well-known Member

sijpie

Well-known Member

carcharoth2554

New Member

carcharoth2554

New Member

Similar threads

Share this page

Using VBA to list and sort folders and files in Excel

carcharoth2554

New Member

carcharoth2554

New Member

sijpie

Well-known Member

sijpie

Well-known Member

sijpie

Well-known Member

carcharoth2554

New Member

carcharoth2554

New Member

Similar threads

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock