2
我需要列出網絡中的所有文件和文件夾，因此需要更快更好的VBA目錄列表器。列出excel中文件夾和子文件夾中的所有文件
這個問題在很多論壇中都有提及，在這裏也有如下面的鏈接。
Loop through files in a folder using 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 delcaration 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
，另一種被再次使用風向從該站點
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
與FileSystemObject的速度比較慢相比DIR。
所以，我的問題是
如何使用迪爾，包括屬性在「文件名（如配方），創建日期，上次訪問，最後修改日期」修改第二碼以格式碼。 （代碼給出「FileDateTime（sName）」日期&時間，但我需要這些在前面的代碼。）
此外，如果列表超過行限制，代碼應創建另一個表與文件夾名稱-2等，並繼續從哪裏結束。其次，我需要它從另一個工作表範圍，如Sheet1.Range（「A2」）。結束（Xlup），而不是使用filedialog或硬編碼，創建文件夾選項卡並運行代碼採取一個文件夾路徑在一次。
能否請您進一步解釋你的答案 – Somar