Option Explicit
Function GoodFileExtension(fName As String) As Boolean
If Len(fName) <= 4 Then Exit Function
Select Case Right(fName, 4)
Case ".xls", ".doc", ".pdf"
GoodFileExtension = True
Case Else
End Select
End Function
Sub doADirectory(whatDir As String, OutputCell As Range)
Dim aFileName As String, FullName As String, i As Integer
ReDim FolderList(1 To 1) As String
aFileName = Dir(whatDir, &H1F)
'cheating a bit here; look up DIR in XL VBE help for 2nd argument
OutputCell.Value = whatDir
Set OutputCell = OutputCell.Offset(1, 1)
Do While aFileName <> ""
If aFileName = "." Or aFileName = ".." _
Or Not GoodFileExtension(aFileName) Then
Else
FullName = whatDir & aFileName
If (GetAttr(FullName) _
And vbDirectory) = vbDirectory Then
ReDim Preserve FolderList(LBound(FolderList) To UBound(FolderList) + 1)
FolderList(UBound(FolderList)) = aFileName
Else
OutputCell.Value = aFileName
Set OutputCell = OutputCell.Offset(1, 0)
End If
End If
aFileName = Dir
Loop
For i = LBound(FolderList) + 1 To UBound(FolderList)
doADirectory whatDir & FolderList(i) & Application.PathSeparator, OutputCell
Set OutputCell = OutputCell.Offset(0, -1)
Next i
End Sub
Sub startADir()
'doADirectory "c:my documents", Range("a1")
doADirectory Range("dirName"), Range(Range("OutputStartCell"))
'The cell named dirName should have the full path of the directory _
including the trailing _
The cell named OutputStartCell should have the address of where _
the output should start, such as A1.
End Sub
If you want to do this yourself, check out Inputbox, GetSaveAsFileName and GetOpenFileName
