|
如果我们要在Excel中获取某个文件夹中所有的文件列表，可以通过下面的VBA代码来进行。代码运行后，首先弹出一个浏览文件夹对话框，然后新建一个工作簿，并在工作表的A至F列分别列出选定文件夹中的所有文件的文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下：
1.按Alt+F11，打开VBA编辑器，单击菜单“插入→模块”，将下面的代码粘贴到右侧的代码窗口中：
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(strFolder & "\" &
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
' 将文件列表放到数组
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”，单击“运行”按钮。
|
