Macro to Display Folder Contents

E

erock24

Well-known Member
Joined
Oct 26, 2006
Messages
1,163
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.
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Sort by date Sort by votes
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]
 
Upvote 0
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.
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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"
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Extracting specific folder files details within parent directory
Replies
1
Views
77
don2303
D
H
  • Question
An idea on handling serial numbers?
Replies
5
Views
66
Micron
M
A
  • Solved
How can I exclude subfolders in a subfolder
Replies
5
Views
368
Ascherith
A
J
  • Question
VBA to List all Folders, Subfolders and files in a directory
Replies
4
Views
744
Formula11
F
S
  • Question
Vba code to open all excel files along with excel name and date modified and data inside the excel
Replies
0
Views
61
suyogpat
S

Forum statistics

Threads
1,214,812
Messages
6,121,696
Members
449,048
Latest member
81jamesacct

Share this page

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
Back
Top