Get sub-folders name with files name by VBA

Question

I want to get subfolders name with files name through Excel VBA.
What I really want is Column A shows subfolders name, Column B shows files name.

Here is my code:

Option Explicit

Private xRow As Long

Sub Get_MAIN_File_Names()
    Dim fso As FileSystemObject
    Dim xDirect As String
    Dim xRootFolder As Folder
    Dim DrawingNumb As String
    Dim RevNumb As String
    Dim rootFolderStr As String

    Set fso = New FileSystemObject
    xRow = 0
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Select Main File"
       .Show

       'PROCESS ROOT FOLDER
       If .SelectedItems.Count <> 0 Then
          xDirect = .SelectedItems(1) & "\"
          Set xRootFolder = fso.GetFolder(xDirect)
          ProcessFolder fso, xRootFolder
       End If

    End With

End Sub

Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
    Dim xFiles As Files
    Dim xFile As File
    Dim xSubFolders As Folders
    Dim xSubFolder As Folder
    Dim xSubFolderName As String
    Dim xFileName As String
    Dim xFileTime As String

    Set xFiles = xFolder.Files
    'Adding Column names
    Cells(1, "A").Value = "SubFolder Name"
    Cells(1, "B").Value = "File Name"
    Cells(1, "C").Value = "Modified Date/Time"

    For Each xSubFolder In xSubFolders
       xSubFolderName = xSubFolder.Name
       ActiveCell.Offset(xRow, 0) = xSubFolderName
       xRow = xRow + 1
    Next xSubFolder

    'LOOPS THROUGH EACH FILE NAME IN FOLDER
    For Each xFile In xFiles

      'EXTRACT INFORMATION FROM FILE NAME
       xFileName = xFile.Name
       xFileTime = xFile.DateLastModified

      'INSERT INFO INTO EXCEL
       ActiveCell.Offset(xRow, 1) = xFileName
       ActiveCell.Offset(xRow, 2) = xFileTime
       xRow = xRow + 1
    Next xFile

    Set xSubFolders = xFolder.SubFolders
    For Each xSubFolder In xSubFolders
        ProcessFolder fso, xSubFolder
    Next xSubFolder

End Sub

However, I don't get what I want. I think the problem is here:

For Each xSubFolder In xSubFolders
   xSubFolderName = xSubFolder.Name
   ActiveCell.Offset(xRow, 0) = xSubFolderName
   xRow = xRow + 1
Next xSubFolder

Which part do I ignore? Or is there another way to solve?
I think the code is too long. Maybe inefficient. How to modify the code?

Answer 1

Your entire

For Each xSubFolder In xSubFolders
   xSubFolderName = xSubFolder.Name
   ActiveCell.Offset(xRow, 0) = xSubFolderName
   xRow = xRow + 1
Next xSubFolder

section is going to fail because you haven't defined xSubFolders at that point. Even if it didn't fail, it wouldn't do what you wanted because it would be moving the writing of the subfolder name away from the rows where you are writing the file details.

To resolve your issue you should delete that section and simply write the folder name out at the same time as you write the file details:

Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
    Dim xFiles As Files
    Dim xFile As File
    Dim xSubFolders As Folders
    Dim xSubFolder As Folder
    Dim xFileName As String
    Dim xFileTime As String

    Set xFiles = xFolder.Files
    Set xSubFolders = xFolder.SubFolders
    'Adding Column names
    'This should really be done once in the main procedure, rather than being performed
    'for every folder processed, but is simply overwriting the information written
    'last time through so will be inefficient but not incorrect.
    Cells(1, "A").Value = "SubFolder Name"
    Cells(1, "B").Value = "File Name"
    Cells(1, "C").Value = "Modified Date/Time"

    'LOOPS THROUGH EACH FILE NAME IN FOLDER
    For Each xFile In xFiles

      'EXTRACT INFORMATION FROM FILE NAME
       xFileName = xFile.Name
       xFileTime = xFile.DateLastModified

      'INSERT INFO INTO EXCEL
       ActiveCell.Offset(xRow, 0) = xFolder.Name
       ActiveCell.Offset(xRow, 1) = xFileName
       ActiveCell.Offset(xRow, 2) = xFileTime
       xRow = xRow + 1
    Next xFile

    Set xSubFolders = xFolder.SubFolders
    For Each xSubFolder In xSubFolders
        ProcessFolder fso, xSubFolder
    Next xSubFolder

End Sub

Answer 2

Try this version.

Sub TestListFolders()

    Application.ScreenUpdating = False

     'create a new workbook for the folder list

     'commented out by dr
     'Workbooks.Add

     'line added by dr to clear old data
    Cells.Delete

     ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With

    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "Folder Name:"
    Range("C3").Formula = "Size:"
    Range("D3").Formula = "Subfolders:"
    Range("E3").Formula = "Files:"
    Range("F3").Formula = "Short Name:"
    Range("G3").Formula = "Short Path:"
    Range("A3:G3").Font.Bold = True

     'ENTER START FOLDER HERE
     ' and include subfolders (true/false)
    ListFolders "C:\Users\Excel\Desktop\Coding\Microsoft Excel\Work Samples\Finance\", True

    Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

     'line added by dr for repeated "Permission Denied" errors

    On Error Resume Next

     ' display folder properties
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, 1).Formula = SourceFolder.Path
    Cells(r, 2).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If

    Columns("A:G").AutoFit

    Set SourceFolder = Nothing
    Set FSO = Nothing

     'commented out by dr
     'ActiveWorkbook.Saved = True

End Sub

As an alternative, you can download the sample file from the link below (click 'Download Now'). That Macro will do a nice job for you.

http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

Answer 3

The code you provided is unlikely to work for a number of reasons, have a look at the changes below, which might help:

Private Sub ProcessFolder(FSO as FileSystemObject, xFolder As Folder)
    Dim xFile as File
    Dim CurRow As Integer

    'Your original code was going to wipe over the data when you got to each new SubFolder. This should prevent that:
    For CurRow = 1 to 100000
        If Range("A" & CurRow).Value = "" And Range("B" & CurRow).Value = "" Then Exit For
    Next CurRow
    If CurRow = 1 then
            Range("A1").Value = "Sub Folder Name"
            Range("B1").Value = "File Name"
            Range("C1").Value = "Modified Date/Time"
            CurRow = CurRow + 1
    End If

    Range("A" & CurRow).Value = xFolder.Name
    CurRow = CurRow + 1

    For Each xFile in xFolder.Files
        Range("B" & CurRow).Value = xFile.Name
        Range("C" & CurRow).Value = xFile.DateLastModified
        CurRow = CurRow + 1
    Next xFile
End Sub