List all files in server or folder using Dir


New Member
Nov 26, 2015
Hi Excel Experts,

This is my first post and sorry if there are any mistakes or not conform to rules while asking question. I thank everyone for making this forum a general one as many people can view the questions and learn excel.

I work in excel and I want to extend the discussions of the 2 links below. I need to list all files and folders in a network. This question has been asked in this forum and other forums and some of the codes is found in the web.

I have taken the code from this forum and tried to modify to meet my requirements. But the speed with FilesystemObject is slower compared to dir as discussed in the links of this forum and I am unable to modify the first code to use dir and get the required information as given by 1st code.
My Question is

How to modify 2nd code to first format using Dir, to include the attributes "FileName (as Formula), Ext (as Formula), Date Created, Date Last Accessed, Date Last Modified" in the code. (Code gives "FileDateTime(sName)" date & time but I require these as in the 1st code.)

Also If the list exceeds the row limit i.e. more than 1 million , the code should create another sheet with folder name-2 etc, and continue from where it ended.
Secondly, The code needs to take multiple folder paths from another 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.

I also want error handlers for
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.

'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"
 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

'ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1"
MsgBox ("Done")
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")
    .Rows(1).Value = Split("File,Date,Size", ",")
End With

t = Timer
NoCursing sRoot
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 + _
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

            If jAttr And vbDirectory Then
                If Right(sName, 1) <> "." Then col.Add sName & "\"
                iRow = iRow + 1
                If (iRow And &H3FF) = 0 Then Debug.Print iRow
                Rows(iRow).Range("A1:C1").Value = Array(sName, _
                                                        FileLen(sName), _
            End If
        End If
        sFile = Dir()
    col.Remove 1
End Sub
Thank you once again

Forum statistics

Latest member

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...