List Files In Folder & Subfolders Using DIR

[VijaySM]

I have posted this question here,

vba - List all files in a folder and subfolders in excel - Stack Overflow

http://www.mrexcel.com/forum/excel-q...using-dir.html

This forum has also many related queries as in below links
List folders, subfolders and files using macro

Directory Listing in a Spreadsheet

This forum has also many posts with similar questions.
eg - http://www.excelfox.com/forum/f13/se...-files-vba-86/
http://www.excelfox.com/forum/f2/lis...nd-color-1773/

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

I am using the above 1st code to list the files in server. It is slower compared to 2nd code which uses DIR. Now, I want to modify the 2nd code to give attributes "FileName (as Formula), Ext (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 should be created and files are listed where they end in previous sheet.

I want to get the results as outlined below.

File Name	Ext	File Name	File Size	File Type	Date Created	Date Last Accessed	Date Last Modified	File Path
=LEFT(C2,FIND("#",SUBSTITUTE(C2,".","#",LEN(C2)-LEN(SUBSTITUTE(C2,".",""))))-1)	=TRIM(RIGHT(SUBSTITUTE(C2,".",REPT(" ",LEN(C2))),LEN(C2)))	ABC_New.xls	024 KB	Microsoft Office Excel 97-2003 Worksheet	12/30/2014 8:30:02 AM	8/4/2015 8:25:51 PM	3/30/2015 9:58:14 AM	\\Server\projects\ABC_New.xls

The path can be a local drive or server.

1. The code should take path from a sheet range like Sheet1.Range("A2").End(Xlup) or using filedialog but not hardcoded, create folder names as excel worksheets and run one folder path at a time. Sometimes when I run above code 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.

a. Permission denied (available in 2nd code) as in "C:\PerfLogs".
b. 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.

I asked in other forums and searched the web but I didn't get the exact result but got very similar using FileScriptingObject but not DIR. Is it possible only with DIR command Or need to combine both FileScriptingObject & DIR.

Thanks in Advance
VijaySM