轉自：http://hi.baidu.com/mwia/blog/item/f88059d20f7198083af3cfc5.html
如果我們要在Excel中獲取某個文件夾中所有的文件列表，可以通過下面的VBA代碼來進行。代碼運行後，首先彈出一個瀏覽文件夾對話框，然後新建一個工作簿，並在工作表的A至F列分別列出選定文件夾中的所有文件的文件名、文件大小、創建時間、修改時間、訪問時間及完整路徑。方法如下：
1.按Alt+F11，打開VBA編輯器，單擊菜單“插入→模塊”，將下面的代碼粘貼到右側的代碼窗口中：
Option Explicit
Sub GetFileList()
Dim strFolder As String
Dim varFileList As Variant
Dim FSO As Object, myFile As Object
Dim myResults As Variant
Dim l As Long
'顯示打開文件夾對話框
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub '未選擇文件夾
strFolder = .SelectedItems(1)
End With
'獲取文件夾中的所有文件列表
varFileList = fcnGetFileList(strFolder)
If Not IsArray(varFileList) Then
MsgBox "未找到文件", vbInformation
Exit Sub
End If
'獲取文件的詳細信息，並放到數組中
ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)
myResults(0, 0) = "文件名"
myResults(0, 1) = "大小（字節）"
myResults(0, 2) = "創建時間"
myResults(0, 3) = "修改時間"
myResults(0, 4) = "訪問時間"
myResults(0, 5) = "完整路徑"
Set FSO = CreateObject("Scripting.FileSystemObject")
For l = 0 To UBound(varFileList)
Set myFile = FSO.GetFile(CStr(varFileList(l)))
myResults(l + 1, 0) = CStr(varFileList(l))
myResults(l + 1, 1) = myFile.Size
myResults(l + 1, 2) = myFile.DateCreated
myResults(l + 1, 3) = myFile.DateLastModified
myResults(l + 1, 4) = myFile.DateLastAccessed
myResults(l + 1, 5) = myFile.Path
Next l
fcnDumpToWorksheet myResults
Set myFile = Nothing
Set FSO = Nothing
End Sub
Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
' 如果文件夾中包含文件返回一個二維數組，否則返回False
Dim f As String
Dim i As Integer
Dim FileList() As String
If strFilter = "" Then strFilter = "*.*"
Select Case Right$(strPath, 1)
Case "/", "/"
strPath = Left$(strPath, Len(strPath) - 1)
End Select
ReDim Preserve FileList(0)
f = Dir$(strPath & "/" & strFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop
If FileList(0) <> Empty Then
fcnGetFileList = FileList
Else
fcnGetFileList = False
End If
End Function
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'新建一個工作簿
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub
2.關閉VBA編輯器，回到Excel工作表中，按Alt+F8，打開“宏”對話框，選擇“GetFileList”，單擊“運行”按鈕。