Monty
Well-Known Member
Hello Everyone!
Found some quick code which can list all the files in a folder and sub folder with all the information...Really appreciating the guy who has written code and trying to tweek as per my requirments..
Code Retrieve all files within a specified folder and all its subfolders and create a list of all file names & paths
Just need to tweek to get the exact size of the file size and only excel files.
Found some quick code which can list all the files in a folder and sub folder with all the information...Really appreciating the guy who has written code and trying to tweek as per my requirments..
Code Retrieve all files within a specified folder and all its subfolders and create a list of all file names & paths
Just need to tweek to get the exact size of the file size and only excel files.
Code:
Option Explicit
Public varFileList As Variant
Public dblTimerResult As Double
Public lngFiles As Long
' ----------------------------------------------------------------------------------------------------------------------------------
Sub RetrieveFilesandFolders()
' Main routine to retrieve all files from a user defined folder and its subfolders
Dim intDialogue As Integer
Dim lngRowCount As Long
Dim strPath As String
Dim objFso As Object
On Error Resume Next
' Initialize
EHTimer 0
Application.ScreenUpdating = False
Application.StatusBar = "Initializing..."
' Clear existing data and resize list object
With ActiveSheet
With .ListObjects("tab_files")
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
If .DataBodyRange.Rows.Count > 1 Then .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
.DataBodyRange.Rows(1).ClearContents
End With
.UsedRange
End With
' Open folder dialog window
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Folder."
intDialogue = Application.FileDialog(msoFileDialogFolderPicker).Show
' Retrieve the list of files
If intDialogue <> 0 Then
strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Application.StatusBar = "Detecting count of files..."
lngFiles = CountFiles(strPath)
ReDim varFileList(1 To lngFiles, 1 To ActiveWorkbook.Worksheets(1).ListObjects("tab_files").DataBodyRange.Columns.Count)
Set objFso = CreateObject("Scripting.FileSystemObject")
lngRowCount = RetrieveFiles(strPath, objFso, 1)
RetrieveFolders strPath, objFso, lngRowCount
End If
' Transfer data to worksheet
Application.StatusBar = "Updating the data table..."
With ActiveWorkbook.Worksheets(1).ListObjects("tab_files")
.Resize ActiveSheet.Range(.Range.Resize(lngFiles + 1, .Range.Columns.Count).Address)
.DataBodyRange.Value = varFileList
End With
' Sort list descending by path length
Application.StatusBar = "Sorting and finalizing..."
With ActiveSheet
.ListObjects("tab_files").Sort.SortFields.Clear
.ListObjects("tab_files").Sort.SortFields.Add Key:= _
Range("tab_files[[#All],[Path Length]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
With .ListObjects("tab_files").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
' Clean up
Set objFso = Nothing
Erase varFileList
Application.ScreenUpdating = True
Application.StatusBar = Empty
' Inform the user
EHTimer
MsgBox Format(lngFiles, "#,##0") & " filenames imported. Duration: " & Format(Round(dblTimerResult, 0) / 86400, "hh:mm:ss"), _
vbInformation, "Import completed"
End Sub
' ----------------------------------------------------------------------------------------------------------------------------------
' Function to retrieve all files inside the defined folder and write the information to the list object on the worksheet
Private Function RetrieveFiles(ByVal strPath As String, ByRef objFso As Object, ByVal lngRow As Long) As Long
Dim lngCount As Long
Dim objFolder As Object
Dim objFile As Object
On Error Resume Next
Set objFolder = objFso.Getfolder(strPath)
lngCount = lngRow
If objFolder.Files.Count > 0 Then
For Each objFile In objFolder.Files
If lngCount Mod 100 = 0 Then
EHTimer
Application.StatusBar = "Processed files " & Format(lngCount, "#,##0") & " of " & Format(lngFiles, "#,##0") & _
" (" & Format(lngCount / lngFiles, "0%") & " completed). " & _
"Elapsed time: " & Format(Round(dblTimerResult, 0) / 86400, "hh:mm:ss")
DoEvents
End If
varFileList(lngCount, 1) = objFile.Name
varFileList(lngCount, 2) = objFile.Path
varFileList(lngCount, 3) = objFile.Size
varFileList(lngCount, 4) = objFile.Type
varFileList(lngCount, 5) = objFile.DateCreated
varFileList(lngCount, 6) = objFile.DateLastModified
varFileList(lngCount, 7) = objFile.DateLastAccessed
varFileList(lngCount, 8) = Len(objFile.Name)
varFileList(lngCount, 9) = Len(objFile.Path)
lngCount = lngCount + 1
Next objFile
End If
RetrieveFiles = lngCount
Set objFolder = Nothing
Set objFile = Nothing
End Function
' ----------------------------------------------------------------------------------------------------------------------------------
' Sub to loop through all folders inside a defined folder (recursive sub)
Private Sub RetrieveFolders(ByVal strFolder As String, ByRef objFso As Object, ByRef lngRow As Long)
Dim objFolder As Object
Dim objSubFolder As Object
On Error Resume Next
Set objFolder = objFso.Getfolder(strFolder)
For Each objSubFolder In objFolder.subFolders
With objSubFolder
lngRow = RetrieveFiles(.Path, objFso, lngRow)
Call RetrieveFolders(.Path, objFso, lngRow)
End With
Next objSubFolder
Set objFolder = Nothing
Set objSubFolder = Nothing
End Sub
' ----------------------------------------------------------------------------------------------------------------------------------
Private Function CountFiles(strFolder As String) As Long
' Count files in the folder and its subfolders
Dim objFso As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim lngCount As Long
On Error Resume Next
' Initialize
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objSubFolders = objFso.Getfolder(strFolder).subFolders
'Count files (that match the extension if provided)
lngCount = objFso.Getfolder(strFolder).Files.Count
'Count files in subfolders
For Each objSubFolder In objSubFolders
lngCount = lngCount + CountFiles(objSubFolder.Path)
Next objSubFolder
CountFiles = lngCount
End Function
' ----------------------------------------------------------------------------------------------------------------------------------
Public Sub EHTimer(Optional varStart As Variant)
' Timer (provided by Daniel Ferry in the Excel Hero Academy): called when starting and stopping the timer
If IsMissing(varStart) Then
dblTimerResult = Timing
Else
Timing = 0
End If
End Sub
Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
#Else
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
#End If
Dim m_Time As Double
Dim m_TimeFreq As Double
Dim m_TimeStart As Currency
Public Property Get Timing() As Double
Dim curTime As Currency
QueryPerformanceCounter curTime
Timing = (curTime - m_TimeStart) * m_TimeFreq + m_Time
End Property
Public Property Let Timing(ByVal NewValue As Double)
Dim curFreq As Currency
Dim curOverhead As Currency
m_Time = NewValue
QueryPerformanceFrequency curFreq
m_TimeFreq = 1 / curFreq
QueryPerformanceCounter curOverhead
QueryPerformanceCounter m_TimeStart
m_TimeStart = m_TimeStart + (m_TimeStart - curOverhead)
End Property
