I have posted this question here,
This forum has also many related queries as in below links
The above code is very near to what I want but it is slower when there are thousands of files in a folder. So I am trying to use dir or want to combine both dir & ScriptingObject and get the details as given by 1st code. I have got many answers and modified the code but not been able to get the details as in 1st code using Dir.
'Force the explicit delcaration of variables Option Explicit 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 Dim n As Long Dim Msg As Byte Dim Drilldown As Boolean 'Assign the top folder to a variable 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) Msg = MsgBox("Do you want to list all files in descendant folders, too?", _ vbInformation + vbYesNo, "Drill-Down") If Msg = vbYes Then Drilldown = True Else Drilldown = False End With ' create a new sheet If Len(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)) < 31 Then ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1) Else: ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1), 31) End If 'Insert the headers for Columns A through F Range("A1").Value = "File Name" Range("B1").Value = "Ext" Range("C1").Value = "File Name" Range("D1").Value = "File Size" Range("E1").Value = "File Type" Range("F1").Value = "Date Created" Range("G1").Value = "Date Last Accessed" Range("H1").Value = "Date Last Modified" Range("I1").Value = "File Path" '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, Drilldown) 'Change the width of the columns to achieve the best fit 'Columns.AutoFit 'ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1" MsgBox ("Done") ActiveWorkbook.Save Sheet1.Activate 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 Dim strTopFolderName As String Dim n As Long Dim maxRows As Long Dim sheetNumber As Integer maxRows = 1048576 '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 'to take complete filename in column C and extract filename without extension lso allowing for fullstops in filename itself Cells(NextRow, "A") = "=LEFT(RC[+2],FIND(""#"",SUBSTITUTE(RC[+2],""."",""#"",LEN(RC[+2])- LEN(SUBSTITUTE(RC[+2],""."",""""))))-1)" 'to take complete filename from row C and show only its extension Cells(NextRow, "B") = "=TRIM(RIGHT(SUBSTITUTE(RC[+1],""."",REPT("" "",LEN(RC[+1]))),LEN(RC[+1])))" Cells(NextRow, "C").Value = objFile.Name Cells(NextRow, "D").Value = Format((objFile.Size / 1024), "000") & " KB" Cells(NextRow, "E").Value = objFile.Type Cells(NextRow, "F").Value = objFile.DateCreated Cells(NextRow, "G").Value = objFile.DateLastAccessed Cells(NextRow, "H").Value = objFile.DateLastModified Cells(NextRow, "I").Value = objFile.Path NextRow = NextRow + 1 Next objFile ' If "descendant" folders also get their files listed, then sub calls itself recursively If IncludeSubFolders Then For Each objSubFolder In objFolder.SubFolders Call RecursiveFolder(objSubFolder, True) Next objSubFolder End If 'Loop through files in the subfolders 'If IncludeSubFolders Then ' For Each objSubFolder In objFolder.SubFolders ' If Msg = vbYes Then Drilldown = True Else Drilldown = False ' Call RecursiveFolder(objSubFolder, True) 'Next objSubFolder 'End If If n = maxRows Then sheetNumber = sheetNumber + 1 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) 'ActiveSheet.Name = "Sheet-" & sheetNumber ActiveSheet.Name = strTopFolderName & "_" & sheetNumber n = 0 End If n = n + 1 End Sub
Sub ListFiles() Const sRoot As String = "C:\" Dim t As Date Application.ScreenUpdating = False With Columns("A:C") .ClearContents .Rows(1).Value = Split("File,Date,Size", ",") End With t = Timer NoCursing sRoot Columns.AutoFit Application.ScreenUpdating = True MsgBox Format(Timer - t, "0.0s") End Sub Sub NoCursing(ByVal sPath As String) Const iAttr As Long = vbNormal + vbReadOnly + _ vbHidden + vbSystem + _ vbDirectory Dim col As Collection Dim iRow As Long Dim jAttr As Long Dim sFile As String Dim sName As String If Right(sPath, 1) <> "\" Then sPath = sPath & "\" Set col = New Collection col.Add sPath iRow = 1 Do While col.Count sPath = col(1) sFile = Dir(sPath, iAttr) Do While Len(sFile) sName = sPath & sFile On Error Resume Next jAttr = GetAttr(sName) If Err.Number Then Debug.Print sName Err.Clear Else If jAttr And vbDirectory Then If Right(sName, 1) <> "." Then col.Add sName & "\" Else iRow = iRow + 1 If (iRow And &H3FF) = 0 Then Debug.Print iRow Rows(iRow).Range("A1:C1").Value = Array(sName, _ FileLen(sName), _ FileDateTime(sName)) End If End If sFile = Dir() Loop col.Remove 1 Loop End Sub
The speed with FilesystemObject is slower compared to dir. I am trying to modify the 2nd code to give attributes "FileName (as Formula), Date Created, Date Last Accessed, Date Last Modified" as in the 1st code. Also If the list exceeds the row limit, another sheet with folder name-2 is created and files are listed.
The path is in range of a sheet like Sheet1.Range("A2").End(Xlup) and not using filedialog or hardcoded, create folder tabs and run the code taking one folder path at a time. Sometimes when I run these codes i get Permission denied errors for recycle bin, perf logs etc for which i have no access, I have included "On Error Resume Next", but I want it to give which folder has errors and continue.
1. Permission denied (available in 2nd code) as in "C:\PerfLogs"
2. Formula errors if file names contains certain characters or if file has no extension. eg- "_INCAP~1" - Here i ext column it can give "No Extension" for such files.
File listing of all files including subfolders
Thanks in Advance