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

Question

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

这个问题在许多论坛中都有人提出，也在这里，如以下链接所示:

Loop through files in a folder using VBA?

Get list of sub-directories in VBA

List files in folder and subfolder with path to .txt file

我使用了一些并修改了这里的代码:

http://www.mrexcel.com/forum/excel-questions/56980-file-listing-all-files-including-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

http://www.mrexcel.com/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 的速度较慢。

所以，我的问题是:

如何使用 Dir 将第二个代码修改为第一个格式，以在代码中包含属性“文件名(作为公式)、创建日期、上次访问日期、上次修改日期”。 (代码给出了“FileDateTime(sName)”日期和时间，但我需要像前面的代码一样的这些。)

此外，如果列表超出行限制，代码应创建另一个具有文件夹 name-2 等的工作表，并从结束处继续。

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

Answer 1

将所有 Long 和 Integer 数据类型转换为 CLngPtr(variable)

在 Sub 行之后添加 Application.ScreenUpdating = False。

在 End Sub 行之前添加 Application.ScreenUpdating = True。