通过VBA获取带有文件名的子文件夹名称答案

【问题标题】：Get sub-folders name with files name by VBA通过VBA获取带有文件名的子文件夹名称
【发布时间】：2017-12-26 07:52:26
【问题描述】：

我想通过 Excel VBA 获取 子文件夹 名称和文件名。
我真正想要的是Column A 显示子文件夹名称，Column B 显示文件名。

这是我的代码：

Option Explicit

Private xRow As Long

Sub Get_MAIN_File_Names()
    Dim fso As FileSystemObject
    Dim xDirect As String
    Dim xRootFolder As Folder
    Dim DrawingNumb As String
    Dim RevNumb As String
    Dim rootFolderStr As String

    Set fso = New FileSystemObject
    xRow = 0
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Select Main File"
       .Show

       'PROCESS ROOT FOLDER
       If .SelectedItems.Count <> 0 Then
          xDirect = .SelectedItems(1) & "\"
          Set xRootFolder = fso.GetFolder(xDirect)
          ProcessFolder fso, xRootFolder
       End If

    End With

End Sub

Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
    Dim xFiles As Files
    Dim xFile As File
    Dim xSubFolders As Folders
    Dim xSubFolder As Folder
    Dim xSubFolderName As String
    Dim xFileName As String
    Dim xFileTime As String

    Set xFiles = xFolder.Files
    'Adding Column names
    Cells(1, "A").Value = "SubFolder Name"
    Cells(1, "B").Value = "File Name"
    Cells(1, "C").Value = "Modified Date/Time"

    For Each xSubFolder In xSubFolders
       xSubFolderName = xSubFolder.Name
       ActiveCell.Offset(xRow, 0) = xSubFolderName
       xRow = xRow + 1
    Next xSubFolder

    'LOOPS THROUGH EACH FILE NAME IN FOLDER
    For Each xFile In xFiles

      'EXTRACT INFORMATION FROM FILE NAME
       xFileName = xFile.Name
       xFileTime = xFile.DateLastModified

      'INSERT INFO INTO EXCEL
       ActiveCell.Offset(xRow, 1) = xFileName
       ActiveCell.Offset(xRow, 2) = xFileTime
       xRow = xRow + 1
    Next xFile

    Set xSubFolders = xFolder.SubFolders
    For Each xSubFolder In xSubFolders
        ProcessFolder fso, xSubFolder
    Next xSubFolder

End Sub

但是，我没有得到我想要的。我认为问题出在这里：

For Each xSubFolder In xSubFolders
   xSubFolderName = xSubFolder.Name
   ActiveCell.Offset(xRow, 0) = xSubFolderName
   xRow = xRow + 1
Next xSubFolder

我忽略了哪一部分？或者有没有别的办法解决？
我认为代码太长了。也许效率低下。如何修改代码？

【问题讨论】：

我认为如果你删除你认为有问题的整个部分，而是在你写出其他信息的部分中添加一行 ActiveCell.Offset(xRow, 0) = xFolder.Name ，它可能会起作用。
参考this
@YowE3K 太好了。有用。我想你可以回答这个问题，我会标记它。

标签： vba excel

【解决方案1】：

你的全部

For Each xSubFolder In xSubFolders
   xSubFolderName = xSubFolder.Name
   ActiveCell.Offset(xRow, 0) = xSubFolderName
   xRow = xRow + 1
Next xSubFolder

部分将失败，因为那时您还没有定义xSubFolders。即使它没有失败，它也不会做你想做的事，因为它会将子文件夹名称的写入从你正在写入文件详细信息的行中移开。

要解决您的问题，您应该删除该部分，并在写入文件详细信息的同时简单地写下文件夹名称：

Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
    Dim xFiles As Files
    Dim xFile As File
    Dim xSubFolders As Folders
    Dim xSubFolder As Folder
    Dim xFileName As String
    Dim xFileTime As String

    Set xFiles = xFolder.Files
    Set xSubFolders = xFolder.SubFolders
    'Adding Column names
    'This should really be done once in the main procedure, rather than being performed
    'for every folder processed, but is simply overwriting the information written
    'last time through so will be inefficient but not incorrect.
    Cells(1, "A").Value = "SubFolder Name"
    Cells(1, "B").Value = "File Name"
    Cells(1, "C").Value = "Modified Date/Time"

    'LOOPS THROUGH EACH FILE NAME IN FOLDER
    For Each xFile In xFiles

      'EXTRACT INFORMATION FROM FILE NAME
       xFileName = xFile.Name
       xFileTime = xFile.DateLastModified

      'INSERT INFO INTO EXCEL
       ActiveCell.Offset(xRow, 0) = xFolder.Name
       ActiveCell.Offset(xRow, 1) = xFileName
       ActiveCell.Offset(xRow, 2) = xFileTime
       xRow = xRow + 1
    Next xFile

    Set xSubFolders = xFolder.SubFolders
    For Each xSubFolder In xSubFolders
        ProcessFolder fso, xSubFolder
    Next xSubFolder

End Sub

【讨论】：

【解决方案2】：

试试这个版本。

Sub TestListFolders()

    Application.ScreenUpdating = False

     'create a new workbook for the folder list

     'commented out by dr
     'Workbooks.Add

     'line added by dr to clear old data
    Cells.Delete

     ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With

    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "Folder Name:"
    Range("C3").Formula = "Size:"
    Range("D3").Formula = "Subfolders:"
    Range("E3").Formula = "Files:"
    Range("F3").Formula = "Short Name:"
    Range("G3").Formula = "Short Path:"
    Range("A3:G3").Font.Bold = True

     'ENTER START FOLDER HERE
     ' and include subfolders (true/false)
    ListFolders "C:\Users\Excel\Desktop\Coding\Microsoft Excel\Work Samples\Finance\", True

    Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

     'line added by dr for repeated "Permission Denied" errors

    On Error Resume Next

     ' display folder properties
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, 1).Formula = SourceFolder.Path
    Cells(r, 2).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If

    Columns("A:G").AutoFit

    Set SourceFolder = Nothing
    Set FSO = Nothing

     'commented out by dr
     'ActiveWorkbook.Saved = True

End Sub

您也可以从下面的链接下载示例文件（单击“立即下载”）。那个宏会为你做得很好。

http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

【讨论】：

【解决方案3】：

由于多种原因，您提供的代码不太可能正常工作，请查看以下更改，这可能会有所帮助：

Private Sub ProcessFolder(FSO as FileSystemObject, xFolder As Folder)
    Dim xFile as File
    Dim CurRow As Integer

    'Your original code was going to wipe over the data when you got to each new SubFolder. This should prevent that:
    For CurRow = 1 to 100000
        If Range("A" & CurRow).Value = "" And Range("B" & CurRow).Value = "" Then Exit For
    Next CurRow
    If CurRow = 1 then
            Range("A1").Value = "Sub Folder Name"
            Range("B1").Value = "File Name"
            Range("C1").Value = "Modified Date/Time"
            CurRow = CurRow + 1
    End If

    Range("A" & CurRow).Value = xFolder.Name
    CurRow = CurRow + 1

    For Each xFile in xFolder.Files
        Range("B" & CurRow).Value = xFile.Name
        Range("C" & CurRow).Value = xFile.DateLastModified
        CurRow = CurRow + 1
    Next xFile
End Sub

【讨论】：

"当您到达每个新的子文件夹时，您的原始代码将擦除数据。" - 实际上，它不会 - 他们总是写到行 xRow （一个模块范围变量），并在每次写入后将其递增 1。存在一个问题，他们将Get_MAIN_File_Names 中的xRow 初始化为0，而应将其初始化为2，但无论处理多少子文件夹，这都是一个问题。（一旦他们将其修复为适用于第一个文件夹，所有其他文件夹都会正确地写在它下面。）
@YowE3K 抱歉，我错过了 xRow 的定义。不过，我仍然会调整代码的其他部分，因为除非您以后需要，否则无需将数据存储为单独的变量。唯一的例外是处理速度，在这种情况下，您可以构建所有数据的数组，然后在最后一次命中全部写入（对于您要处理的文件数量可能可以忽略不计）。
是的，我同意xFileName = xFile.Name 毫无意义，这就是为什么我只是添加了写xFolder.Name 的行，而不是将其放入临时变量中。（我想将文件夹名称放入临时变量可能会提高效率，这样.Name 属性只被访问一次，而不是文件夹中的每个文件 - 但存储xFile.Name 和@ 绝对没有优势987654331@.) 但我不想过多地更改 OP 的代码，特别是因为他们已经从评论中得到了答案，所以可能永远看不到它。 :D
@YowE3K 很公平。
@PeterChen 除非您有数千个文件，或者您每天多次运行代码，否则对当前解决方案的任何改进可能都不值得重写它。对于工作代码的“优化解决方案”的请求应该在 Code Review 而不是 Stack Overflow 上提出。