excel利用VBA获取文件夹中的文件列表

来源:互联网 时间:2016-01-03

如果我们要在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”,单击“运行”按钮。

相关阅读:
Top