List only the first file of each folder & subfolder of a user specified directory.

[WashCAPS]

I see a lot of posts regarding creating a list of all files in a folder and sub folders of a user specified directory but I need help modifying the code below to select only the first file in each folder and subfolder. Is this even possible?

TIA

WashCAPS

Sub ListFiles()

'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)

'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String

'Insert the headers for Columns A through F
Range("A1").Value = "File Name"
Range("B1").Value = "File Size"
Range("C1").Value = "File Type"
Range("D1").Value = "Date Created"
Range("E1").Value = "Date Last Accessed"
Range("F1").Value = "Date Last Modified"

'Pick folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Pick a folder"
.Show

If .SelectedItems.Count = 0 Then MsgBox "Operation cancelled by the user", vbExclamation + vbOKOnly, "List Files": Exit Sub
strTopFolderName = .SelectedItems(1)
End With

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)

'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)

'Change the width of the columns to achieve the best fit
Columns.AutoFit

End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)

'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long

'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1

'Loop through each file in the folder
For Each objFile In objFolder.Files
Cells(NextRow, "A").Value = objFile.Name
Cells(NextRow, "B").Value = objFile.Size
Cells(NextRow, "C").Value = objFile.Type
Cells(NextRow, "D").Value = objFile.DateCreated
Cells(NextRow, "E").Value = objFile.DateLastAccessed
Cells(NextRow, "F").Value = objFile.DateLastModified
NextRow = NextRow + 1
Next objFile

'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If

End Sub

 

[humdingaling]

could you just have a variable to count the number of times its looped in folder
make it skip rest of folder once counter reaches 2 and reset counter back to 1?

 

[humdingaling]

actually the way your code is structured something like this would work

Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)

'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
Dim i As Long

'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
i = NextRow

'Loop through each file in the folder
For Each objFile In objFolder.Files
    If i = NextRow Then
        Cells(NextRow, "A").Value = objFile.Name
        Cells(NextRow, "B").Value = objFile.Size
        Cells(NextRow, "C").Value = objFile.Type
        Cells(NextRow, "D").Value = objFile.DateCreated
        Cells(NextRow, "E").Value = objFile.DateLastAccessed
        Cells(NextRow, "F").Value = objFile.DateLastModified
        NextRow = NextRow + 1
    End If
Next objFile

just add variable
make it = nextrow and then
extra if statement to your loop

 

[WashCAPS]

My apologies for the delay humdinaling. I think your first suggestion could work but I went with your second suggestion as it worked great! Very much appreciated!