Text Functions‎ > ‎

Directory Listing

"I'd like to be able to get a quick 'list' of all the files in a directory along with hyperlinks for opening them if needed."

  1. User can pick any folder
  2. User can specify which file type they want to get a listing of, or use * for all
  3. Option to turn the list created into a hyperlinked directory to open listed files
  4. Show the last modified time of each file in created listing


Option Explicit

Sub HyperlinkDirectory()
'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      10/8/2010
'Summary:   User selects a folder and file type, macro returns
'           a complete listing of all files matching that type
'           with a hyperlink to the file for ease of opening
Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

'Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "C:\2009\"
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
            Exit Sub
        End If
    End With

'Types of files
    fType = Application.InputBox("What kind of files? Type the file extension to collect" _
            & vbLf & vbLf & "(Example:  pdf, doc, txt, xls, *)", "File Type", "pdf", Type:=2)
    If fType = "False" Then Exit Sub
'Option to create hyperlinks
    AddLinks = MsgBox("Add hyperlinks to the file listing?", vbYesNo) = vbYes
'Create report
    Application.ScreenUpdating = False
    NR = 5
    With Sheets("Sheet1")
        .[A1] = "Directory"
        .[B1] = fPath
        .[A2] = "File type"
        .[B2] = fType
        .[A4] = "File"
        .[B4] = "Modified"
        fname = Dir(fPath & "*." & fType)
        Do While Len(fname) > 0
            .Range("A" & NR) = fname
            .Range("B" & NR) = FileDateTime(fPath & fname)
            If AddLinks Then .Hyperlinks.Add Anchor:=Range("A" & NR), _
                Address:=fPath & fname, _
                TextToDisplay:=fPath & fname
          'set for next entry
            NR = NR + 1
            fname = Dir
    End With
    Application.ScreenUpdating = True
End Sub

Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!