Macro to Display Folder Contents

erock24

Well-known Member
Joined
Oct 26, 2006
Messages
1,160
Is there a macro that can return the details of files (names and modified dates) in a given folder. Put names in A2 down and Dates in B2 down (or something).

Thank you.
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
Code:
[B]Public strFolderNm$[/B]
 
[COLOR=black][B]Sub File_Listing()[/B][/COLOR]
[COLOR=darkgreen]'Standard module code, like: Module1.[/COLOR]
Dim objFileScript As Object, objFolder As Object, objThisFile As Object, objThisFolder
Dim strFileCreate$, strFileAccess$, strFileDtMod$, strAttrNm$
Dim strFileNm$, strFileType$, strFileAttr$, strFilePath$
Dim dubFileSize#
Dim lngAttr&
 
[COLOR=navy]Call[/COLOR] mySelectFolderOnly

[COLOR=darkgreen]'strFolderNm = CurDir[/COLOR]
ActiveSheet.Columns("A:H").Delete Shift:=xlToLeft
ActiveSheet.Range("A1").Select
Selection.Value = "Folder"
Selection.Offset(0, 1).Value = "Name.Ext"
Selection.Offset(0, 2).Value = "Size"
Selection.Offset(0, 3).Value = "Units"
Selection.Offset(0, 4).Value = "Type"
Selection.Offset(0, 5).Value = "Created"
Selection.Offset(0, 6).Value = "Last Access"
Selection.Offset(0, 7).Value = "Last Modified"
Selection.Offset(0, 8).Value = "Attribute"
ActiveSheet.Range("A1:I1").Font.Bold = True
 
Set objFileScript = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileScript.GetFolder(strFolderNm)
Set objThisFolder = objFolder.Files
 
For Each objThisFile In objThisFolder
strFilePath = objThisFile.Path
strFileNm = objThisFile.Name
dubFileSize = objThisFile.Size
strFileType = objThisFile.Type
strFileCreate = objThisFile.DateCreated
strFileAccess = objThisFile.DateLastAccessed
strFileDtMod = objThisFile.DateLastModified
strAttrNm = ""
lngAttr = 0
lngAttr = objThisFile.Attributes
 
If lngAttr = 0 Then
strAttrNm = strAttrNm & "Normal"
ElseIf lngAttr = 16 Then
strAttrNm = strAttrNm & "Directory "
ElseIf lngAttr = 1 Then
strAttrNm = strAttrNm & "Read-Only "
ElseIf lngAttr = 2 Then
strAttrNm = strAttrNm & "Hidden "
ElseIf lngAttr = 4 Then
strAttrNm = strAttrNm & "Normal System "
ElseIf lngAttr = 8 Then
strAttrNm = strAttrNm & "Volume "
ElseIf lngAttr = 32 Then
strAttrNm = strAttrNm & "Archive "
ElseIf lngAttr = 1024 Then
strAttrNm = strAttrNm & "Alias "
ElseIf lngAttr = 2048 Then
strAttrNm = strAttrNm & "Compressed "
Else

strAttrNm = strAttrNm & "Hidden System "
End If
 
strFileAttr = strAttrNm
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Value = strFilePath
Selection.Offset(0, 1).Value = strFileNm
Selection.Offset(0, 2).Value = Format(dubFileSize, "###,###,###")
Selection.Offset(0, 3).Value = " Bytes"
Selection.Offset(0, 4).Value = strFileType
Selection.Offset(0, 5).Value = strFileCreate
Selection.Offset(0, 6).Value = strFileAccess
Selection.Offset(0, 7).Value = strFileDtMod
Selection.Offset(0, 8).Value = strFileAttr
Next objThisFile
 
ShowSubFolders objFileScript.GetFolder(strFolderNm)
Columns("A:H").Columns.AutoFit
[B]End Sub[/B]
 
[B]Private Sub mySelectFolderOnly()[/B]
[COLOR=darkgreen]'Standard module code, like: Module1.[/COLOR]
Dim strMyDrive$, strFilePath$
 
Application.DisplayAlerts = False

On Error GoTo myError
 
[COLOR=darkgreen]'Display Folder Shell, for you to select your Folder!
'(a,b,c,d)= b==> "Title"
'(a,b,c,d)= d==> 17=AllFilesDeskTop(MyComputer), 0=Root(DeskTop), 18=Network, 19=NetHood,
'23=Common(Programs), 2=Top(Programs), 38=All(Programs), 33=cookies, 16=DeskTop, 6=Favorites,
'5=MyDocuments, 4=Printers&Faxs, 27=PrintHood, 32=TempInterNet, 8=Recent,
'11=StartMenu, 7=StartUp(Only), 21=Templates, 36=Windows , 39=MyPictures,
'5=Personal(MyDocuments)[/COLOR]
[COLOR=#006400][/COLOR]
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Select the Folder to use!", 0, 17)
 
If Not objFolder Is Nothing Then
If Len(objFolder.Items.Item.Path) > 3 Then
strFolderNm = objFolder.Items.Item.Path & Application.PathSeparator
Else
 
strFolderNm = objFolder.Items.Item.Path
End If
End If
 
[COLOR=darkgreen]'Cancel Dialog then Exit![/COLOR]
If strFolderNm = "" Then GoTo myEnd
 
[COLOR=darkgreen]'Hold your selected Folder!
'ChDir strFolderNm
'strFilePath = strFolderNm[/COLOR]
[COLOR=darkgreen]'Work with selected folder.
'MsgBox strFilePath
[/COLOR]Exit Sub
 
[COLOR=darkgreen]'On error Display error information and help!
[/COLOR]myError:
MsgBox "On ""OK"" will Exit you back to your sheet!" & vbCr & vbCr & _
"Error Source: " & Err.Source & vbCr & _
"Error Number: " & Err.Number & vbCr & _
"Error Type: " & Err.Description & vbCr _
, vbMsgBoxHelpButton _
, "Error Accessing, " & strFilePath & ", Drive: " & strMyDrive _
, Err.HelpFile _
, Err.HelpContext
GoTo myEnd
 
myEnd:
[B]End Sub[/B]
 
[B]Sub myClearDisplay()[/B]
[COLOR=darkgreen]'Standard module code, like: Module1.[/COLOR]
[COLOR=#006400][/COLOR] 
ActiveSheet.Columns("A:H").Delete Shift:=xlToLeft
ActiveSheet.Range("A1").Select
End Sub
 
[B]Sub ShowSubFolders(Folder)[/B]
For Each Subfolder In Folder.SubFolders
 
Set objFileScript = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileScript.GetFolder(Subfolder.Path)
Set objThisFolder = objFolder.Files
 
For Each objThisFile In objThisFolder
strFilePath = objThisFile.Path
strFileNm = objThisFile.Name
dubFileSize = objThisFile.Size
strFileType = objThisFile.Type
strFileCreate = objThisFile.DateCreated
strFileAccess = objThisFile.DateLastAccessed
strFileDtMod = objThisFile.DateLastModified
strAttrNm = ""
lngAttr = 0
lngAttr = objThisFile.Attributes
 
If lngAttr = 0 Then
strAttrNm = strAttrNm & "Normal"
ElseIf lngAttr = 16 Then
strAttrNm = strAttrNm & "Directory "
ElseIf lngAttr = 1 Then
strAttrNm = strAttrNm & "Read-Only "
ElseIf lngAttr = 2 Then
strAttrNm = strAttrNm & "Hidden "
ElseIf lngAttr = 4 Then
strAttrNm = strAttrNm & "Normal System "
ElseIf lngAttr = 8 Then
strAttrNm = strAttrNm & "Volume "
ElseIf lngAttr = 32 Then
strAttrNm = strAttrNm & "Archive "
ElseIf lngAttr = 1024 Then
strAttrNm = strAttrNm & "Alias "
ElseIf lngAttr = 2048 Then
strAttrNm = strAttrNm & "Compressed "
Else

strAttrNm = strAttrNm & "Hidden System "
End If
 
strFileAttr = strAttrNm
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Value = strFilePath
Selection.Offset(0, 1).Value = strFileNm
Selection.Offset(0, 2).Value = Format(dubFileSize, "###,###,###")
Selection.Offset(0, 3).Value = " Bytes"
Selection.Offset(0, 4).Value = strFileType
Selection.Offset(0, 5).Value = strFileCreate
Selection.Offset(0, 6).Value = strFileAccess
Selection.Offset(0, 7).Value = strFileDtMod
Selection.Offset(0, 8).Value = strFileAttr
Next objThisFile
Next
[B]End Sub[/B]
 

erock24

Well-known Member
Joined
Oct 26, 2006
Messages
1,160
follow up question...how could I make it pull from the same folder each time without having to browse. I have a situation where a hard keyed path would work better for me.

Thank you for your time and help.
 

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539

ADVERTISEMENT

Remove the folder function call:

Call mySelectFolderOnly

and the Function, then change:

Set objFolder = objFileScript.GetFolder(strFolderNm)

to

Set objFolder = objFileScript.GetFolder("C:\Excel\Test\Work")
or what ever your file path is!
 
Last edited:

erock24

Well-known Member
Joined
Oct 26, 2006
Messages
1,160

ADVERTISEMENT

Along with the properties, is it possible to bring back the value in cell b3 located on each one of the sheets in my folder. Here is the working code after the changes:

Thankyou.

Code:
Public strFolderNm$
Sub File_Listing()
'Standard module code, like: Module1.
Dim objFileScript As Object, objFolder As Object, objThisFile As Object, objThisFolder
Dim strFileCreate$, strFileAccess$, strFileDtMod$, strAttrNm$
Dim strFileNm$, strFileType$, strFileAttr$, strFilePath$
Dim dubFileSize#
Dim lngAttr&

'strFolderNm = CurDir
ActiveSheet.Cells.Delete
Cells.EntireColumn.Hidden = False

ActiveSheet.Range("A4").Value = "Folder"
ActiveSheet.Range("B4").Value = "Name.Ext"
ActiveSheet.Range("C4").Value = "Last Access"
ActiveSheet.Range("D4").Value = "Last Modified"
ActiveSheet.Range("E4").Value = "Created"
ActiveSheet.Range("F4").Value = "Size"
ActiveSheet.Range("G4").Value = "Units"
ActiveSheet.Range("H4").Value = "Type"
ActiveSheet.Range("I4").Value = "Attribute"
ActiveSheet.Range("A4:I4").Font.Bold = True
 
Set objFileScript = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileScript.GetFolder("C:\Users\Harskey\Desktop\Excel Stuff")
Set objThisFolder = objFolder.Files
 
For Each objThisFile In objThisFolder
strFilePath = objThisFile.Path
strFileNm = objThisFile.Name
dubFileSize = objThisFile.Size
strFileType = objThisFile.Type
strFileCreate = objThisFile.DateCreated
strFileAccess = objThisFile.DateLastAccessed
strFileDtMod = objThisFile.DateLastModified
strAttrNm = ""
lngAttr = 0
lngAttr = objThisFile.Attributes
 
If lngAttr = 0 Then
strAttrNm = strAttrNm & "Normal"
ElseIf lngAttr = 16 Then
strAttrNm = strAttrNm & "Directory "
ElseIf lngAttr = 1 Then
strAttrNm = strAttrNm & "Read-Only "
ElseIf lngAttr = 2 Then
strAttrNm = strAttrNm & "Hidden "
ElseIf lngAttr = 4 Then
strAttrNm = strAttrNm & "Normal System "
ElseIf lngAttr = 8 Then
strAttrNm = strAttrNm & "Volume "
ElseIf lngAttr = 32 Then
strAttrNm = strAttrNm & "Archive "
ElseIf lngAttr = 1024 Then
strAttrNm = strAttrNm & "Alias "
ElseIf lngAttr = 2048 Then
strAttrNm = strAttrNm & "Compressed "
Else

strAttrNm = strAttrNm & "Hidden System "
End If
 
strFileAttr = strAttrNm
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
Selection.Value = strFilePath
Selection.Offset(0, 1).Value = strFileNm
Selection.Offset(0, 2).Value = strFileAccess
Selection.Offset(0, 3).Value = strFileDtMod
Selection.Offset(0, 4).Value = strFileCreate
Selection.Offset(0, 5).Value = Format(dubFileSize, "###,###,###")
Selection.Offset(0, 6).Value = " Bytes"
Selection.Offset(0, 7).Value = strFileType
Selection.Offset(0, 8).Value = strFileAttr
Next objThisFile
Columns("A:H").Columns.AutoFit
Columns("A:A").Insert Shift:=xlToRight
Range("A4").FormulaR1C1 = "File"
Range("A5").FormulaR1C1 = "=HYPERLINK(RC2)"
On Error Resume Next
Range("A5").AutoFill Destination:=Range("A5:A" & Range("B" & Rows.Count).End(xlUp).Row), Type:=xlFillDefault
Columns("B:B").EntireColumn.Hidden = True
With ActiveSheet.Range("C1")
.Value = "Posted Manual Sheet Inventory - Balance Sheet"
.Font.Bold = True
End With
With ActiveSheet.Range("C2")
.FormulaR1C1 = "As of " & Date
.Font.Bold = True
End With
Application.Goto reference:="R1C1"
End Sub
 

tusharm

MrExcel MVP
Joined
May 28, 2002
Messages
11,028
Adjust the below to account for where where you want the information and which sheet the information will come from.
Code:
Selection.Offset(0, 9).Formula = "='" _
    & Left(strFilePath, InStrRev(strFilePath, Application.PathSeparator)) _
    & "[" & strFileNm & "]sheet1'!$B$3"
 

Watch MrExcel Video

Forum statistics

Threads
1,122,606
Messages
5,597,134
Members
414,128
Latest member
Jorglo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top