列出Excel中的文件夹和子文件夹中的所有文件

本文介绍了列出Excel中的文件夹和子文件夹中的所有文件的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述

我需要列出网络中的所有文件和文件夹，因此需要更快，更好的VBA目录列表器.

I need to list all files and folders in a network and hence require a faster and better VBA directory lister.

这个问题在许多论坛中都被问到了，也可以在下面的链接中找到:

This question is asked in many forums and also here as in the below links:

使用VBA遍历文件夹中的文件吗?

获取VBA中的子目录列表

在文件夹和子文件夹中列出文件.txt文件的路径

我用过一些，并从这里修改了代码:

I have used some and modified the code from here:

http ://www.mrexcel/forum/excel-questions/56980-file-listing-all-files- includes-subfolders-2.html ，如下所示.

'Force the explicit declaration of variables Option Explicit Sub ListFiles() 'Set a reference to Microsoft Scripting Runtime by using 'Tools > References in the Visual Basic Editor (Alt+F11) 'Declare the variables Dim objFSO As Scripting.FileSystemObject Dim objTopFolder As Scripting.Folder Dim strTopFolderName As String Dim n As Long Dim Msg As Byte Dim Drilldown As Boolean 'Assign the top folder to a variable With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "Pick a folder" .Show If .SelectedItems.Count = 0 Then MsgBox "Operation Cancelled by the user", vbExclamation + vbOKOnly, "List Files": Exit Sub strTopFolderName = .SelectedItems(1) Msg = MsgBox("Do you want to list all files in descendant folders, too?", _ vbInformation + vbYesNo, "Drill-Down") If Msg = vbYes Then Drilldown = True Else Drilldown = False End With ' create a new sheet If Len(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)) < 31 Then ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1) Else: ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1), 31) End If 'Insert the headers for Columns A through F Range("A1").Value = "File Name" Range("B1").Value = "Ext" Range("C1").Value = "File Name" Range("D1").Value = "File Size" Range("E1").Value = "File Type" Range("F1").Value = "Date Created" Range("G1").Value = "Date Last Accessed" Range("H1").Value = "Date Last Modified" Range("I1").Value = "File Path" 'Create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Get the top folder Set objTopFolder = objFSO.GetFolder(strTopFolderName) 'Call the RecursiveFolder routine Call RecursiveFolder(objTopFolder, Drilldown) 'Change the width of the columns to achieve the best fit 'Columns.AutoFit 'ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1" MsgBox ("Done") ActiveWorkbook.Save Sheet1.Activate End Sub Sub RecursiveFolder(objFolder As Scripting.Folder, _ IncludeSubFolders As Boolean) 'Declare the variables Dim objFile As Scripting.File Dim objSubFolder As Scripting.Folder Dim NextRow As Long Dim strTopFolderName As String Dim n As Long Dim maxRows As Long Dim sheetNumber As Integer maxRows = 1048576 'Find the next available row NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1 'Loop through each file in the folder For Each objFile In objFolder.Files 'to take complete filename in column C and extract filename without extension lso allowing for fullstops in filename itself Cells(NextRow, "A") = "=LEFT(RC[+2],FIND(""#"",SUBSTITUTE(RC[+2],""."",""#"",LEN(RC[+2])- LEN(SUBSTITUTE(RC[+2],""."",""""))))-1)" 'to take complete filename from row C and show only its extension Cells(NextRow, "B") = "=TRIM(RIGHT(SUBSTITUTE(RC[+1],""."",REPT("" "",LEN(RC[+1]))),LEN(RC[+1])))" Cells(NextRow, "C").Value = objFile.Name Cells(NextRow, "D").Value = Format((objFile.Size / 1024), "000") & " KB" Cells(NextRow, "E").Value = objFile.Type Cells(NextRow, "F").Value = objFile.DateCreated Cells(NextRow, "G").Value = objFile.DateLastAccessed Cells(NextRow, "H").Value = objFile.DateLastModified Cells(NextRow, "I").Value = objFile.Path NextRow = NextRow + 1 Next objFile ' If "descendant" folders also get their files listed, then sub calls itself recursively If IncludeSubFolders Then For Each objSubFolder In objFolder.SubFolders Call RecursiveFolder(objSubFolder, True) Next objSubFolder End If 'Loop through files in the subfolders 'If IncludeSubFolders Then ' For Each objSubFolder In objFolder.SubFolders ' If Msg = vbYes Then Drilldown = True Else Drilldown = False ' Call RecursiveFolder(objSubFolder, True) 'Next objSubFolder 'End If If n = maxRows Then sheetNumber = sheetNumber + 1 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) 'ActiveSheet.Name = "Sheet-" & sheetNumber ActiveSheet.Name = strTopFolderName & "_" & sheetNumber n = 0 End If n = n + 1 End Sub

另一个人从该站点再次使用Dir

and another one is using Dir again from that site

www.mrexcel/forum/excel-questions/656026-better-way-listing-folders-subfolders-contents.html

Sub ListFiles() Const sRoot As String = "C:\" Dim t As Date Application.ScreenUpdating = False With Columns("A:C") .ClearContents .Rows(1).Value = Split("File,Date,Size", ",") End With t = Timer NoCursing sRoot Columns.AutoFit Application.ScreenUpdating = True MsgBox Format(Timer - t, "0.0s") End Sub Sub NoCursing(ByVal sPath As String) Const iAttr As Long = vbNormal + vbReadOnly + _ vbHidden + vbSystem + _ vbDirectory Dim col As Collection Dim iRow As Long Dim jAttr As Long Dim sFile As String Dim sName As String If Right(sPath, 1) <> "\" Then sPath = sPath & "\" Set col = New Collection col.Add sPath iRow = 1 Do While col.Count sPath = col(1) sFile = Dir(sPath, iAttr) Do While Len(sFile) sName = sPath & sFile On Error Resume Next jAttr = GetAttr(sName) If Err.Number Then Debug.Print sName Err.Clear Else If jAttr And vbDirectory Then If Right(sName, 1) <> "." Then col.Add sName & "\" Else iRow = iRow + 1 If (iRow And &H3FF) = 0 Then Debug.Print iRow Rows(iRow).Range("A1:C1").Value = Array(sName, _ FileLen(sName), _ FileDateTime(sName)) End If End If sFile = Dir() Loop col.Remove 1 Loop End Sub

与dir相比，FilesystemObject的速度较慢.

The speed with FilesystemObject is slower compared to dir.

所以，我的问题是:

如何使用Dir将第二个代码修改为第一种格式，以在代码中包含属性文件名(作为公式)，创建日期，最后访问日期，最后修改日期" . (代码给出了"FileDateTime(sName)"的日期和时间，但我需要像以前的代码中那样.)

How to modify 2nd code to first format using Dir, to include the attributes "FileName (as Formula), Date Created, Date Last Accessed, Date Last Modified" in the code. (Code gives "FileDateTime(sName)" date & time but I require these as in the previous code.)

此外，如果列表超出行数限制，则代码应使用文件夹名称2等创建另一个工作表，然后从结束处继续.

Also If the list exceeds the row limit, code should create another sheet with folder name-2 etc, and continue from where it ended.

第二，我需要它从另一个工作表范围(如Sheet1.Range("A2").End(Xlup))中获取多个文件夹路径，而不使用文件对话框或硬编码，创建文件夹选项卡并运行在一个文件夹中使用一个文件夹路径的代码时间.

Secondly I need it to take multiple folder paths from another sheet range like Sheet1.Range("A2").End(Xlup) and not using filedialog or hardcoded, create folder tabs and run the code taking one folder path at a time.

推荐答案

'MODULE 3 '==================================================================== 'STT: 10 = 'Ten Ham: Search_Celllast_Data(row_find, col_find) = 'Chuc nang: Tim kiem o cuoi cung co du lieu trong Sheet = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/23 = '==================================================================== Public Sub Search_Celllast_Data(row_find As Integer, col_find As Integer) Dim row_last As Integer Dim col_last As Integer row_find = 0 col_find = 0 'Lay vi tri o cuoi cung trong sheet Call Search_Cell_Last(row_last, col_last) 'Lay ra o cuoi cung co du lieu For row_active = 1 To row_last For col_active = 1 To col_last If Cells(row_active, col_active) <> "" Then 'Lay hang lon nhat co chua du lieu row_find = row_active 'Lay cot lon nhat co chua du lieu If col_find < col_active Then col_find = col_active End If End If Next col_active Next row_active End Sub '==================================================================== 'STT: 11 = 'Ten Ham: Delete_Row(row_delete) = 'Chuc nang: Xoa mot hang duoc chi dinh voi kich thuoc cho truoc = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/23 = '==================================================================== Public Sub Delete_Row(row_delete As Integer) Rows(row_delete).Delete Shift:=xlUp End Sub '==================================================================== 'STT: 12 = 'Ten Ham: Sum_Range(row_start,col_start,row_end,col_end) = 'Chuc nang: Tinh tong cac so trong mot vung = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/23 = '==================================================================== Public Function Sum_Range(row_start As Integer, col_start As Integer, row_end As Integer, col_end As Integer) As Integer Dim sum_temp As Integer sum_temp = 0 For row_active = row_start To row_end For col_active = col_start To col_end If IsNumeric(Cells(row_active, col_active)) Then sum_temp = sum_temp + Cells(row_active, col_active) Else MsgBox ("SUM_RANGE: Trong vung tinh tong co du lieu khong phai so.") Sum_Range = 0 Exit Function End If Next col_active Next row_active Sum_Range = sum_temp End Function '==================================================================== 'STT: 13 = 'Ten Ham: Open_File(path_file) = 'Chuc nang: Mo file bang path = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Sub Open_File(path_file As String) Workbooks.Open Filename:=path_file End Sub '==================================================================== 'STT: 14 = 'Ten Ham: Close_File(file_name) = 'Chuc nang: Dong file bang ten = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Sub Close_File(file_name As String) Windows(file_name).Activate ActiveWindow.Close End Sub '==================================================================== 'STT: 15 = 'Ten Ham: Save_File(file_name) = 'Chuc nang: Luu file bang ten = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Sub Save_File(file_name As String) ActiveWorkbook.Save End Sub '==================================================================== 'STT: 16 = 'Ten Ham: Get_Name_Workbook(number_workbook) = 'Chuc nang: Lay ten cua Workbook dua vao so stt = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Function Get_Name_Workbook(number_workbook As Integer) As String Get_Name_Workbook = Workbooks(number_workbook).Name End Function '==================================================================== 'STT: 17 = 'Ten Ham: Get_Name_Worksheet(number_worksheet) = 'Chuc nang: Lay ten cua Worksheet dua vao so stt = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Function Get_Name_Worksheet(number_worksheet As Integer) As String If number_worksheet <= Sheets.Count Then Get_Name_Worksheet = Worksheets(number_worksheet).Name Else MsgBox ("Thu tu sheet da vuot qua tong so sheets.") End If End Function '==================================================================== 'STT: 18 = 'Ten Ham: Copy_Sheet(name_sheet_copy, location_insert) = 'Chuc nang: Copy sheet moi vao vi tri chi dinh = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Sub Copy_Sheet(name_sheet_copy As String, location_insert As Integer) On Error GoTo EXIT_SUB Sheets(name_sheet_copy).Copy Before:=Sheets(location_insert) EXIT_SUB: MsgBox ("COPY_SHEET_NAME: Ten sheet(" + name_sheet_copy + ") khong ton tai.") End Sub '==================================================================== 'STT: 19 = 'Ten Ham: Delete_Sheet(name_sheet_delete) = 'Chuc nang: Xoa sheet duoc chi dinh = 'Nguoi tao: V.Cong = 'Ngay tao: 2017/05/24 = '==================================================================== Public Sub Delete_Sheet(name_sheet_delete As String) On Error GoTo EXIT_SUB Sheets(name_sheet_delete).Delete Exit Sub EXIT_SUB: