Search code examples
vbaexcelsubdirectoryfso

Searching directory for files and listing their name and path - two levels of subfolders

Im currently trying to edit a previously created Macro by another team It very successfully is able to retrieve all file names and paths from a specific location, very useful if all the files are there.

My issue is Im trying to adapt this to another area where the files are held in a "Storage" directory From here they go:

Storage\ProposalFolder\(1 of 3 folders)\File

the 1 of 3 folders thing helps sort them based on what type of proposal they are

Project, Prospect or Suspect

So what I need to do is have a macro thats given the Storage directory and then scans through each Proposal subfolder, then sees which folder type the file is stored in (if the file is in Project, the other 2 folders WILL be empty)

Please see below

Storage View

Storage view

Proposal Folder

1st level view

Project/prospect/suspect folder

File level view

This is the code left behind - I've edited it here and there

Sub ListFilesInDirectory()

If MsgBox("Are you sure you want to list the files?", vbYesNo) = vbNo Then
End
Else
End If

Select Case MsgBox("Press Yes to retrieve ALL files." & vbNewLine & vbNewLine & "Press No to retrieve *** files only", vbQuestion + vbYesNoCancel + vbDefaultButton1, "Which Do You Want To Retrieve?")
Case vbCancel
End
Case vbNo
***_Option = 1
Case vbYes
***_Option = 2
End Select


Dim counter As Single
counter = Timer

On Error GoTo error_message
Application.StatusBar = "The macro is running. Please wait..."


Application.Calculation = xlCalculationManual
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.ScreenUpdating = False


'Populate columns A to C
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet
    Dim objSubfolders As Object

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = ActiveSheet

    startrow = 7


    If IsEmpty(Range("file_directory")) Then
        GoTo skip_this
        Else
        filedir = Range("file_directory").Value
    End If


    'Get the folder object associated with the directory
    Set objFolder = objFSO.GetFolder(filedir)
    Set objSubfolders = objFolder.subfolders
    'ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"

     'Loop through the Files collection
    If ***_Option = 1 Then
     For Each objFile In objFolder.Files
     DoEvents

      If InStr(UCase(objFile.Name), "****") > 0 Then
        ws.Cells(startrow, 1).Value = filedir
'        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
        ws.Cells(startrow, 2).Value = objFile.Name
        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name

        ws.Cells(startrow, 3).Value = objFile.DateLastModified
        startrow = startrow + 1
      End If
     Next
    End If

    If ***_Option = 2 Then
    For Each objFile In objFolder.Files
     DoEvents
        ws.Cells(startrow, 1).Value = filedir
'        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
        ws.Cells(startrow, 2).Value = objFile.Name
        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
        ws.Cells(startrow, 3).Formula = "=CONCATENATE(" & startrow & "2," & startrow & "3)"
        startrow = startrow + 1
     Next

'    For Each SubFolder In objSubfolders
'
'     For Each objFile In objSubfolders.Files
'     DoEvents
'        ws.Cells(startrow, 1).Value = filedir
''        ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
'        ws.Cells(startrow, 2).Value = objFile.Name
'        ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
'        ws.Cells(startrow, 3).Value = objFile.DateLastModified
'        startrow = startrow + 1
'     Next
'    Next SubFolder
    End If


'        For Each SubFolder In SourceFolder.subfolders
'            ListFilesInFolder SubFolder.Path, True
'        Next SubFolder
'
'    If subfolders = True Then
'        For Each SubFolder In SourceFolder.subfolders
'            ListFilesInFolder SubFolder.Path, True
'        Next SubFolder
'    End If

skip_this:
  Next

    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

    lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

'Format any potential error files in red
    Cells.FormatConditions.Delete
    Range("B7:B" & lastrow).Select

    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=RIGHT(B7,5)<>"".xlsm"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LEFT(B7,1)=""~"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = True


'Range("C4").Select
'ActiveCell.FormulaR1C1 = "Date" & Chr(10) & "Modified"

Range("C7:C" & lastrow).Select
Selection.NumberFormat = "dd/mm/yyyy  hh:mm:ss"
Selection.HorizontalAlignment = xlCenter

Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False

MsgBox ("Time taken to list files (hr:min:sec): " & Format((Timer - counter) / 86400, "hh:mm:ss") & vbNewLine & vbNewLine & "Please now do an initial cleanup of the files listed:" & vbNewLine & "  1) Delete any obvious older versions of the files" & vbNewLine & "  2) Files highlighted red are likely to be incorrect and should be deleted")

Exit Sub
error_message:
If Err.Number <> 0 Then
     Msg = "Error # " & Str(Err.Number) & " was generated by " _
         & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
     MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
     End If
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox ("You have entered an incorrect directory path. Please ensure the 3 cells in the Variables tab are showing valid directory paths, or the cells are empty")
End Sub

What I need to do is list the files in the subfolders just like the "For each objFile" code does, but I cant get my head around how to go further than one level of subfolders - the code commented out about subfolders was me :/

Any help would be super!

Solution

  • Further to comments above...

    A recursive procedure generally repeats into "lower levels" by calling itself. Obviously this can cause an issue if not coded properly, but there are countless code example on this site and others, such as:

    Everything you need to know is contained in (or linked from) those pages.