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

sijpie · Apr 26, 2013

Strange: with me your code (unchanged other than the path) gives the subdirectories in column 1 and the main directory in column 3. So I do get a split. Or do you want each subdirectory in a separate column as well?

sijpie · Apr 26, 2013

This will list each subfolder in a separate column and add the subfolder name to row 3

Your problem was that the ListFilesinFolder is a recurring function, so the t was reset to 1 every time. I have now made it a module-level variable, so it will keep its value in the recurrence.
I have also changed the scope of the CheckPath variable, so I can use it in ListFilesinFolder to get the subdirectory name.

Option Explicit Dim t As Integer Dim CheckPath As String Sub GetDirectory() Application.Calculation = xlCalculationManual 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:H3").Font.Bold = True t = 1 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 c As Integer Dim strAddress As String Dim strDisplayText As String Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.GetFolder(SourceFolderName) r = 4 'first row for the file list ' 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 ' put subfolder name in row 3 Cells(3, t) = Right(SubFolder.Path, Len(SubFolder.Path) - Len(CheckPath)) 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

sijpie · Apr 26, 2013

If you change the line

Rich (BB code):

    Worksheets("Register").Range("A1:H999").ClearContents

to

Rich (BB code):

    Worksheets("Register").Cells.ClearContents

then it doesn't matter how many subdirectories there are, else it wouldn't delete columns after column H

As for speed, because you are writing several times to each cell (to enter the value and to put the hyperlinking in place, it will be relatively slow. Probably more so if your directories are on a shared drive.

carcharoth2554 · May 3, 2013

Hi sijpie! Sorry for the late reply, I didn't get a notification for some reason.

You were correct in your assessment; I did want the different sub-dirs listed in separate columns (don't overly care to much about the filepaths, just the sorting of the files themselves). Unfortunately you are also correct in saying the directories are on a shared drive so this is making things very slow. Unfortunately that is not my choice to make so I have to deal with it.

I am going to have a crack at integrating this code this afternoon (as mine has changed slightly from the one posted) and I will update you if this solves things!

These files will rarely be moved or deleted for any reason, the update is more for picking up new additions. If there is no way to speed up the code as you mentioned then I am thinking about instead having this first function for an all over wipe and re-read that is used infrequently and a second more frequently used function that leaves existing data and tries to pick up any files subsequently added. Any thoughts on the feasibility of this? I cannot rely on the static data of the files as these are submitted by dozens of people and the file system is unregulated so all I have to go on is the filename itself reading week1, week2, week3 etc.

Thanks a lot for all your time!

sijpie · May 3, 2013

Do you need the hyperlinks to the cells? otherwise I can get all the info into one array and write it only once which will improve speed considerably on large datasets.

Also for a weekly update, we could do something like load all the files in the array, load the current stored data into an other array, compare the two and only add the new ones. That means only first time around will it be slow. We could do this keeping the hyperlinks

carcharoth2554 · May 3, 2013

sijpie said:
Also for a weekly update, we could do something like load all the files in the array, load the current stored data into an other array, compare the two and only add the new ones. That means only first time around will it be slow. We could do this keeping the hyperlinks

Unfortunately I do require the links even if that is at the cost of some runtime. I can deal with that however as the second part of your response sounds right on the mark. Sorry to ask but working with arrays is not a part of my vba strengths, any chance you could outline for me a snippet of how you would read the data into an array please? I think (hope) I will be able to take it from there and integrate that into my code also

Thanks again!!

sijpie · May 3, 2013

it's a bit tricky until you understand it. I am working on a version right now, so should have it with you in a short while. This question about to include subfolders or not, will you ever answer no? makes coding a bit easier.

carcharoth2554 · May 3, 2013

sijpie said:
it's a bit tricky until you understand it. I am working on a version right now, so should have it with you in a short while. This question about to include subfolders or not, will you ever answer no? makes coding a bit easier.

No, I was intending on removing that code anyway but just had not got around to it yet

Feel free to remove!

Thanks again! I love this board so much!

sijpie · May 3, 2013

Try this code on its own (amend the directory path first). This uses arrays and lists the files in columns, but does not add any hyperlinks yet. Stick it in a file point it to a directory (preferaly a shared large directory) and see if it is significantly quicker.

I will continue with the hyperlink stuff.
Option Explicit Dim t As Integer Dim CheckPath As String Dim aFD As Variant, aHypL As Variant Sub GetDirectory() Application.Calculation = xlCalculationManual Dim Msg As Byte, i As Long Dim Drilldown 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") ' header row of table ' load entire existing page in array aOld = rOut.CurrentRegion 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 For i = 1 To UBound(aFD, 2) ' to be coded Next i .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 Integer Dim c As Integer 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 i As Integer, j As Integer 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 i = 1 To UBound(aFD, 1) For j = 1 To UBound(aFD, 2) aTemp1(i, j) = aFD(i, j) aTemp2(i, j) = aHypL(i, j) Next j Next i ReDim aFD(500 + UBound(aFD, 1), UBound(aFD, 2)) ReDim aHypL(500 + UBound(aFD, 1), UBound(aFD, 2)) For i = 1 To UBound(aFD, 1) For j = 1 To UBound(aFD, 2) aFD(i, j) = aTemp1(i, j) aHypL(i, j) = aTemp2(i, j) Next j Next i ReDim aTemp1(1, 1) ReDim aTemp2(1, 1) End If Next FileItem Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub ''Private Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

Using VBA to list and sort folders and files in Excel

carcharoth2554

New Member

Excel Facts

sijpie

Well-known Member

sijpie

Well-known Member

sijpie

Well-known Member

carcharoth2554

New Member

sijpie

Well-known Member

carcharoth2554

New Member

sijpie

Well-known Member

carcharoth2554

New Member

sijpie

Well-known Member

Similar threads

Forum statistics

Share this page

Using VBA to list and sort folders and files in Excel

New Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

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