Question

我希望通过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

我忽略哪一部分？还是有另一种方法可以解决？我认为代码太长了。可能效率低下。如何修改代码？

Answer 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

Answer 2

您提供的代码不太可能由于多种原因而起作用，请查看下面的更改，这可能有所帮助：

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

Answer 3

试试这个版本。

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/

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

3 个答案: