BadDogTitan
New Member
- Joined
- Sep 16, 2013
- Messages
- 18
This bit of hobbled together VBA from various sources lists all files in the selected directory. They are sorted alphabetically, then enumerated in Column 1, which is also a hyperlink to the folder the file is in. Column 2 is the filename, which is a hyperlink to the actual file. Works great for files.
How do I modify it to list everything in the selected directory, including folders and subfolders?
How do I modify it to list everything in the selected directory, including folders and subfolders?
Code:
Option ExplicitDim r As Integer
Sub ListFiles()
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select directory"
.InitialFileName = ThisWorkbook.Path & "\"
.AllowMultiSelect = False
If .Show = 0 Then Exit Sub
sPath = .SelectedItems(1) & "\"
End With
r = 5: Range(r + 1 & ":" & Rows.Count).Delete
DirList sPath, Cells(r, 1)
End Sub
Sub DirList(ByVal sPath As String, rList As Range)
' Attribute mask
Const iAttr As Long = vbNormal + vbReadOnly + vbSystem + vbDirectory
Dim jAttr As Long ' file attributes
Dim Coll As Collection ' queued directories
Dim iFile As Long ' file counter
Dim sFile As String ' file name
Dim sName As String ' full file name
Dim sn As Variant
Dim sn_tmp As String
Dim x As Integer
Dim lRng As Range
Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set Coll = New Collection
Coll.Add sPath
Do While Coll.Count
sPath = Coll(1)
sFile = Dir(sPath, iAttr)
Do While Len(sFile)
sName = sPath & sFile
On Error Resume Next
jAttr = GetAttr(sName)
If Err.Number Then
MsgBox sName, vbCritical, "File name violation - Error " & Err.Number
' Can't get attributes for files with Unicode characters in
' the name, or some particular files (e.g., "C:\System Volume Information")
Debug.Print sName
Err.Clear
Else
On Error GoTo 0
If jAttr And vbDirectory Then
If Right(sName, 1) <> "." Then Coll.Add sName & "\"
Else
iFile = iFile + 1
With rList
.Cells(iFile, 1).Hyperlinks.Add Anchor:=.Cells(iFile, 1), Address:=sPath, TextToDisplay:=sName
.Cells(iFile, 2).Hyperlinks.Add Anchor:=.Cells(iFile, 2), Address:=sName, TextToDisplay:=sFile
sn = Split(sName, "\")
End With
End If
End If
sFile = Dir()
Loop
Coll.Remove 1
Loop
iFile = iFile + 1
Set lRng = rList.CurrentRegion
With lRng
.AutoFilter Field:=1, VisibleDropDown:=False
.AutoFilter Field:=2, VisibleDropDown:=False
.Sort Key1:=rList.Cells(r, 1), Header:=xlYes
.Font.Underline = False
rList = "1"
Range(rList.Cells(2, 1), lRng(lRng.Rows.Count, 1)).FormulaR1C1 = "=SUBTOTAL(3,R5C[1]:R[-1]C[1])+1"
End With
Columns("A:A").ColumnWidth = 6
Columns("B:B").ColumnWidth = 80
Columns("C:C").ColumnWidth = 10
'Columns.AutoFit
Rows.AutoFit
With ActiveWindow
If .FreezePanes Then .FreezePanes = False
.SplitColumn = 0
.SplitRow = r - 1
.FreezePanes = True
End With
Application.ScreenUpdating = True
lRng.Cells(2, 1).Select
End Sub
IMHO:
