Opening a directory and listing all files within

[jazzman060]

Hello All -

I am trying to create a macro that will prompt the user to select a folder to open, and then list all the file names that appear in that folder and all sub-folders within. The code below pretty much works (for some reason it does not pull files that only have numeric characters) but there is one more step i would like it to do. I am trying to not only get the macro to pull the name of the file, but also the name of the folder directly above it in another column. If anyone can advise how to do so I would be most appreciative. Thank you all for your time.

-d

Dim myFolder As String
Sub SelectFolder(Optional i_RootFolder As String)
Dim myShell As Object

Set myShell = CreateObject("Shell.Application")
If i_RootFolder = "" Then
'no root folder given, use default (which is Desktop)
Set myFolder = myShell.BrowseForFolder(0, "Please select a folder:", 1)
ElseIf Not (i_RootFolder Like "*[!0123456789]*") Then
'number for special folder given
Set myFolder = myShell.BrowseForFolder(0, _
"Please select a folder:", 1, CInt(i_RootFolder))
Else
'path for root folder given
Set myFolder = myShell.BrowseForFolder(0, _
"Please select a folder:", 1, CStr(i_RootFolder))
End If
If Not myFolder Is Nothing Then
SelectFolder = myFolder.Self.path
End If
End Sub

Sub TestListFilesInFolder()
'Dim folder As String

' folder = (myFolder)

Sheets.Add
With ActiveSheet
.Move after:=Worksheets(1)
.Name = "All Part #'s"
End With
Range("A1").Value = "Part #"
Range("B1").Value = "All Subparts"
Range("A1:B1").Font.Bold = True

ListFilesInFolder myFolder, True


' list all files included subfolders
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Name
' FileItem.Delete True
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.path, True
Next SubFolder
End If
Columns("A:H").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub

[jazzman060]

Oh i forgot to include that i am using excel 2003

[figment]

i made some changes to your code, and added the feature that you were looking for. you will have to define where the data is stored but the logic is all there for you.

[VBA]
Dim myFolder As String
Sub SelectFolder(Optional i_RootFolder As String)
Dim myShell As Object

Set myShell = CreateObject("Shell.Application")
If i_RootFolder = "" Then
'no root folder given, use default (which is Desktop)
Set myFolder = myShell.BrowseForFolder(0, "Please select a folder:", 1)
ElseIf Not (i_RootFolder Like "*[!0123456789]*") Then
'number for special folder given
Set myFolder = myShell.BrowseForFolder(0, _
"Please select a folder:", 1, CInt(i_RootFolder))
Else
'path for root folder given
Set myFolder = myShell.BrowseForFolder(0, _
"Please select a folder:", 1, CStr(i_RootFolder))
End If
If Not myFolder Is Nothing Then
SelectFolder = myFolder.Self.Path
End If
End Sub

Sub TestListFilesInFolder()
'Dim folder As String
Dim allpartsheet As Worksheet
' folder = (myFolder)
If IsError(Worksheets("All Part #'s").Select) Then 'makes sure sheet exists
Set allpartsheet = Sheets.Add
With allpartsheet
.Move after:=Worksheets(1)
.Name = "All Part #'s"
End With
End If
Worksheets("All Part #'s").Select
Range("A1").Value = "Part #"
Range("B1").Value = "All Subparts"
Range("A1:B1").Font.Bold = True
myFolder = ActiveWorkbook.Path 'sets path temorary
ListFilesInFolder myFolder, True 'gets all files
Call sortfiles 'puts file info into correct cells

End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim a As Long
With Application.FileSearch
.LookIn = SourceFolderName
.FileType = msoFileTypeAllFiles
.SearchSubFolders = IncludeSubfolders
If .Execute <> 0 Then
r = Range("A65536").End(xlUp).Row
For a = 1 To .FoundFiles.Count
Range("A" & r + a) = .FoundFiles.Item(a)
Next
End If
End With
ActiveWorkbook.Saved = True
End Sub

Sub sortfiles()
Dim a As Long, b As Integer, c As Integer, slength As Integer
Dim filepath As String
c = 0
For a = 2 To Range("A1").End(xlDown).Row
filepath = Range("A" & a)
slength = Range("A" & a).Characters.Count
For b = slength To 1 Step -1
If Mid(filepath, b, 1) = "\" Then
If c = 0 Then
c = b
Range("A" & a) = Mid(filepath, b + 1, slength - (b))
Else
Range("B" & a) = Mid(filepath, b + 1, c - b - 1)
c = 0
b = 1
End If
End If
Next
Next
End Sub[/VBA]

i will be around if you have any questions.

[jazzman060]

Great it works! with some minimal tweaking i was able to get it to function the way i need it to. Thank you for your help