Get data about files in multiple folders VBA

[magges]

Hi guys,

i got a VBA code working for extracting data about files in a specific folder. i would like to know if its possible for me to get data from multiple folders? i would like to add the data from these to my list below. The list below contains data from the folder in the VBA code you can see below.


[TABLE="width: 230"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Filename[/TD]
[TD]Date modified [/TD]
[/TR]
[TR]
[TD]CPM_422.pptx[/TD]
[TD="align: right"]2019-09-09 10:35[/TD]
[/TR]
[TR]
[TD]CPM_517.pptx[/TD]
[TD="align: right"]2019-10-11 09:00[/TD]
[/TR]
[TR]
[TD]CPM_522.pptx[/TD]
[TD="align: right"]2019-06-12 13:29[/TD]
[/TR]
[TR]
[TD]CPM_533.pptx[/TD]
[TD="align: right"]2019-08-15 12:31[/TD]
[/TR]
[TR]
[TD]CPM_538.pptx[/TD]
[TD="align: right"]2019-08-29 10:07[/TD]
[/TR]
</tbody>[/TABLE]

Sub GetFilesDetails()

' enable "microsoft scripting runtime" under tools -> references
' This macro will extract the list of the filenames from a folder as follows


' in column A= Files names
' in column B= Date Created
' in column C= Date Last Accessed
' in column D= Date Last Modified


Dim objFSO As Scripting.FileSystemObject
Dim myFolder As Scripting.Folder
Dim myFile As Scripting.File
Dim R As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myFolder = objFSO.GetFolder("C:\Users\vmgh\1. Portfolio\One pagers")




Application.ScreenUpdating = False


''******************************************************************************
' these 2 code lines will clear the old data in Sheet1 from columns A:D
' Row 1 is for the appropriate headers only


ThisWorkbook.Sheets("Sheet1").Range(Cells(2, 1), Cells(Rows.Count, 2)).ClearContents
R = 2


''********************************************************************


' Here we get the files details from folder and place them in the appropriate cells


For Each myFile In myFolder.Files


       ThisWorkbook.Sheets("Sheet1").Cells(R, 1).Value = myFile.Name
       ThisWorkbook.Sheets("Sheet1").Cells(R, 2).Value = myFile.DateLastModified
       R = R + 1


Next myFile


'''************Resizing the columns width****************


ThisWorkbook.Sheets("Sheet1").Columns("A:B").EntireColumn.AutoFit


Application.ScreenUpdating = True


End Sub

 

[Rijnsent]

Hi Magges,
yes, you can check multiple directories. Do you have a list of the directories? Or do you want to check out all subdirectories of a certain directory?
Koen

 

[magges]

Hi Koen,

I have list of 35 directories.

They all have similar names, but unfortunately there are loads of other files and subfolders in the portfolio file.

C:\Users\vmgh\1. Portfolio\One pagers
C:\Users\vmgh\2. Portfolio\One pagers
C:\Users\vmgh\3. Portfolio\One pagers

Br. Magges

 

[Rijnsent]

Hi Magges,
If that's the logic, you could try something like this:

Sub GetFilesDetails2()

' enable "microsoft scripting runtime" under tools -> references
' This macro will extract the list of the filenames from a folder as follows


' in column A= Files names
' in column B= Date Created
' in column C= Date Last Accessed
' in column D= Date Last Modified


Dim objFSO As Scripting.FileSystemObject
Dim myFolder As Scripting.folder
Dim myFile As Scripting.File
Dim R As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")

Application.ScreenUpdating = False
''******************************************************************************
' these 2 code lines will clear the old data in Sheet1 from columns A:D
' Row 1 is for the appropriate headers only
ThisWorkbook.Sheets("Sheet1").Range(Cells(2, 1), Cells(Rows.Count, 2)).ClearContents
R = 2

''********************************************************************
Set myFolder = objFSO.GetFolder("C:\Users\vmgh\")
'First, loop through all folders in myFolder
For Each fc In myFolder.SubFolders
    'Check if the name contains "porfolio"
    If InStr(LCase(fc.Name), "portfolio") > 0 Then
        'Check if a subdirectory named One pagers exists, loop through files if true
         If objFSO.FolderExists(fc.Path & "\" & "One pagers") Then
            Set LoopFolder = objFSO.GetFolder(fc.Path & "\" & "One pagers")
            For Each myFile In LoopFolder.Files
                ThisWorkbook.Sheets("Sheet1").Cells(R, 1).Value = myFile.Name
                ThisWorkbook.Sheets("Sheet1").Cells(R, 2).Value = myFile.DateLastModified
                R = R + 1
            Next myFile
        End If
    End If
Next fc

'''************Resizing the columns width****************
ThisWorkbook.Sheets("Sheet1").Columns("A:B").EntireColumn.AutoFit

Application.ScreenUpdating = True


End Sub

Cheers,
Koen