Get sub-folders name with files name by VBA - 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