'Code goes in a standard module
 '''''MUST SET REFERENCE to WINDOWS SCRIPT HOST OBJECT MODEL''''''''''''
 
Option Explicit 
 
Sub PopulateDirectoryList() 
     'dimension variables
    Dim objFSO As FileSystemObject, objFolder As Folder 
    Dim objFile As File, strSourceFolder As String, x As Long, i As Long 
    Dim wbNew As Workbook, wsNew As Worksheet 
     
    ToggleStuff False 'turn of screenupdating
     
    Set objFSO = New FileSystemObject 'set a new object in memory
    strSourceFolder = BrowseForFolder 'call up the browse for folder routine
    If strSourceFolder = "" Then Exit Sub 
     
    Workbooks.Add 'create a new workbook
     
    Set wbNew = ActiveWorkbook 
    Set wsNew = wbNew.Sheets(1) 'set the worksheet
    wsNew.Activate 
     'format a header
    With wsNew.Range("A1:F1") 
        .Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date", "Full Path", "Size") 
        .Interior.ColorIndex = 7 
        .Font.Bold = True 
        .Font.Size = 12 
    End With 
     
    With Application.FileSearch 
        .LookIn = strSourceFolder 'look in the folder browsed to
        .FileType = msoFileTypeAllFiles 'get all files
        .SearchSubFolders = True 'search sub directories
        .Execute 'run the search
         
        For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
            i = x 'make the variable i = x
            If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
                i = x - 60000 'set i to the right number for row placement below
                Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index)) 
                With wsNew.Range("A1:F1") 
                    .Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _ 
                    "Last Accessed", "Size") 
                    .Interior.ColorIndex = 7 
                    .Font.Bold = True 
                    .Font.Size = 12 
                End With 
                 
            End If 
            On Error GoTo Skip 'in the event of a permissions error
             
            Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
            With wsNew.Cells(1, 1) 'populate the next row with the variable data
                .Offset(i, 0) = objFile.Name 
                .Offset(i, 1) = Format(objFile.Size, "0,000") & " KB" 
                .Offset(i, 2) = objFile.DateLastModified 
                .Offset(i, 3) = objFile.DateLastAccessed 
                .Offset(i, 4) = objFile.DateCreated 
                .Offset(i, 5) = objFile.Path 
                 
            End With 
             ' Next objFile
Skip: 
             'this is in case a Permission denied error comes up or an unforeseen error
             'Do nothing, just go to next file
        Next x 
        wsNew.Columns("A:F").AutoFit 
         
    End With 
     
     'clear the variables
    Set objFolder = Nothing 
    Set objFile = Nothing 
    Set objFSO = Nothing 
    Set wsNew = Nothing 
    Set wbNew = Nothing 
     
    ToggleStuff True 'turn events back on
End Sub 
Sub ToggleStuff(ByVal x As Boolean) 
    Application.ScreenUpdating = x 
    Application.EnableEvents = x 
End Sub 
 
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant 
     '''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
     ''www.codeguru.com
     
    Dim ShellApp As Object 
    Set ShellApp = CreateObject("Shell.Application"). _ 
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 
     
    On Error Resume Next 
    BrowseForFolder = ShellApp.self.Path 
    On Error GoTo 0 
     
    Set ShellApp = Nothing 
     
    Select Case Mid(BrowseForFolder, 2, 1) 
    Case Is = ":" 
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 
    Case Is = "\" 
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 
    Case Else 
        GoTo Invalid 
    End Select 
    Exit Function 
     
Invalid: 
     
     
    ToggleStuff True 
End Function