Search code examples
excelvbasubdirectory

Traverse subdirectories and open files in those directories

I'm trying to write VBA code that does the following:

  • Finds all *.xlsx and *.xlsm files in specified path and subdirectories
  • Opens each one read-only
  • Copies the contents to the current spreadsheet, then closes file
  • Loops through all files

The closest I've been able to get is derived from Loop Through All Subfolders Using VBA, where FolderPath is "C:\Path\To\Folder":

Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(FolderPath)
Do While queue.Count > 0
    Set oFolder = queue(1)
    queue.Remove 1
    For Each oSubfolder In oFolder.SubFolders
        queue.Add oSubfolder
    Next oSubfolder
    For Each oFile In oFolder.Files
        Length = InStrRev(oFile, "\")
        oFileWB = Right(oFile, Len(oFile) - Length)
        'Open the given .xls* file read-only and suppress link update prompt
        Workbooks.Open FileName:=oFile, ReadOnly:=True, UpdateLinks:=False
        'Get current first empty row of database as first target row
        ftr = ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        'Copy range from target sheet, from hardcoded cell A7 to AE in the bottom-most occupied row
        Workbooks(oFileWB).Sheets("Target Sheet").Range("A7:AE" & Workbooks(oFileWB).Sheets("Target Sheet").Cells(Rows.Count, 1).End(xlUp).Row).Copy
        'Paste above range into the first empty cell of the database
        ThisWorkbook.Worksheets("Database").Range(ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Address).PasteSpecial xlPasteValues
        'Get last row of current database after copying data
        ltr = ThisWorkbook.Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Row
        'Copy date and filepath of sheet into all rows
        ThisWorkbook.Worksheets("Database").Range("AF" & ftr & ":AF" & ltr).Value = Now()
        ThisWorkbook.Worksheets("Database").Range("AG" & ftr & ":AG" & ltr).Value = oFile
        'Close current file and suppress save changes prompt
        Workbooks(oFileWB).Close savechanges:=False
    Next oFile
Loop

This works when nothing is open in those directories.

When one of the files is locked, it starts scanning files in "C:" instead of "C:\Path\To\Folder". This gives a permission error because it tries to open hiberfile.sys. This is a critical problem because this script (a) needs to act in an entirely read-only manner, and (b) files in these directories may be locked at any given time.

Also as a lesser issue - how can I restrict it to opening *.xlsx and *.xlsm files?

Solution

  • SOLVED: Fixed the scanning on C:\ problem -

    this was actually caused by code that defined FolderPath, which was pulled using Range("L4").Value but should have been

    ThisWorkbook.Sheets("Database").Range("L4").Value

    So there was actually nothing wrong with the below code. Apologies for not giving you all complete information!

    The issue of specifying .xls files was fixed using the idea provided by Tim in the above comments.