Question

请允许我先说我对编程非常陌生，这也是我在网站论坛上的第一篇帖子！所以请原谅我，如果没有遵守适当的礼节等。

我要执行的任务是Excel VBA问题。

我正在尝试创建一个工具/宏，对于任何给定的文件夹路径，它都会在Excel电子表格BUT中列出所有文件夹（和子文件夹）中的所有文件（这是关键部分），以忽略以下内容的列表指定的例外。

在过去的几周中，我在互联网上收集了点点滴滴，并设法列出了所有内容（使用FileSystemObject，谢天谢地，这已经在网络上得到了很多回答）。

但是，我一生无法找到允许指定例外的任何内容。

之所以需要这样做，是因为我实际上测试了成千上万个子文件夹和近一百万个文件，所以这需要很多时间（并且必须每月重复一次此过程！）。但是，如果我可以基于整个子文件夹路径或文件夹路径中的字符串指定要忽略的子文件夹（并且有很多），那么（理论上）将为我节省大量时间。

总结并举例说明：

对于顶级文件夹路径：C:\This is the top folder\

其中包含以下子文件夹（每个子文件夹都包含其他子文件夹和文件）：

Sub-folder 1
Sub-folder 2
Sub-folder 3
Sub-folder 4
Sub-folder 5

我想返回所有文件和文件夹，但跳过子文件夹3和5（或跳过子文件夹中的指定子文件夹）。要忽略的子文件夹将基于Excel工作表上另一个选项卡（“例外”）中的指定文件路径。

我对编程非常陌生，并且听说过可能使用Dir对象或Shell对象的说法，但是到目前为止，在我的研究中，FileSystemObject（FSO）是最快/最灵活的，因此希望该解决方案基于使用情况FSO。

当前相关代码摘录如下：

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

    '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
        Cells(NextRow, "A").Value2 = objFile.Path
        Cells(NextRow, "B").Value2 = objFile.Name
        Cells(NextRow, "C").Value = objFile.DateLastModified
        NextRow = NextRow + 1
    Next objFile

    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
End Sub

然后希望结果是列出所有子文件夹中的每个文件，但“例外”选项卡上列出的那些子文件夹除外。

我在这个问题上坚持了很长时间，所以任何帮助将不胜感激！

P.S。如果代码还可以返回“上次修改日期”旁边的上一个保存每个文件的用户（驱动器上约600个用户），那么不那么重要，但是如果这样做的话，奖金也将是很大的。

P.P.S我正在使用的Excel版本是2010。

Answer 1

一种删除某些文件夹的方法：

将文件和信息读入数组
过滤数组
将数组写入工作表

我使用字典收集信息，然后再将其写入数组。

这里是代码，还有一个调用递归例程并写入工作表的例程。

请注意，我已经限定了工作表名称。否则，它默认为活动表，您可能无法对其进行控制。

还请注意，在VBA阵列中工作的过程比原始代码中的多个工作表写入操作要快得多。

Option Explicit
Public dFI As Scripting.Dictionary

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 arrFI(1 To 3) As Variant

    'Loop through each file in the folder
    For Each objFile In objFolder.Files
            arrFI(1) = objFile.Path 'This is superfluous since it is also the key
            arrFI(2) = objFile.Name
            arrFI(3) = objFile.DateLastModified
            dFI.Add Key:=objFile.Path, Item:=arrFI
    Next objFile

    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
End Sub

'----------------------------   
Sub GetList()
    Dim FO As Scripting.Folder
    Dim FSO As Scripting.FileSystemObject
    Dim V As Variant, W As Variant
    Dim vRes As Variant
    Dim I As Long

    Dim WS As Worksheet:            Set WS = Worksheets("sheet1")
    Dim R As Range
        Set R = WS.Cells(1, 1)

        Dim wsEX As Worksheet:      Set wsEX = Worksheets("Exceptions")
        Dim vEX As Variant
        With wsEX
            'assumes exceptions are in column A
            vEX = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        End With

Set FSO = New FileSystemObject
Set FO = FSO.GetFolder("C:\Users\Ron\Documents\Data") 'or whatever
Set dFI = New Scripting.Dictionary

    Call RecursiveFolder(FO, True)

V = dFI.Keys

For Each W In vEX
    V = Filter(V, W, False, vbTextCompare)
Next W

'create results array
ReDim vRes(1 To UBound(V) + 1, 1 To 3)
I = 0
For Each W In V
    I = I + 1
    vRes(I, 1) = W
    vRes(I, 2) = dFI(W)(2)
    vRes(I, 3) = dFI(W)(3)
Next W


With R.Resize(UBound(vRes, 1), UBound(vRes, 2))
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub

如果排除的子文件夹列表很大，则使用autofilter或advancedfilter筛选工作表可能会更快，也可能不会更快。您必须测试一下该方法是否比VBA筛选器功能更快

Answer 2

如果要列出文件夹及其子文件夹中的所有文件路径，请尝试以下操作：

Sub MainList()
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
  If xFolder.Name <> "FOLDER NAME EXCETPTION" then
  Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
  Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Path
  End If
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In xFolder.SubFolders
    ListFilesInFolder xSubFolder.Path, True
  Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function

代码行到打印路径：

Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Path

然后，如果只想打印某些文件的路径，则需要添加如下if语句：

If xFolder.Name <> "FOLDER NAME EXCETPTION" then
      Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
      Application.ActiveSheet.Cells(rowIndex, 2).Formula = xFile.Path
End If

使用FSO循环浏览所有文件和文件夹，但忽略指定的子文件夹/文本字符串

2 个答案: