Question

我一直在尝试编写一些代码，这些代码将深入到目录中的每个文件夹和子文件夹，以列出工作簿中工作表的名称。经过这个论坛帖子的大量时间和帮助后，我已经走到了这一步，但仍然没有一个有效的宏。我确定这很明显，我为血腥道歉，但是有人知道为什么它不起作用吗？谢谢！

Option Explicit

Sub marines()
    Dim FileSystem As Object
    Dim HostFolder As String
    Dim OutputRow
    OutputRow = 2
    HostFolder = "G:\EP\Projects\"
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub


Sub DoFolder(Folder)
    Dim SubFolder
    Dim Workbook As Variant
    Dim wb As Workbook
        Dim ws As Worksheet
    Dim HostFolder
    Dim OutputRow
       OutputRow = 2
       FileType = "*.xls*"
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    For Each Workbook In Folder.SubFolders
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow).Activate
        OutputRow = OutputRow + 1
        Curr_File = Dir(HostFolder & FileType)
        Do Until Curr_File = ""
        For wb = wb.Open(HostFolder & Curr_File, False, True)
                ThisWorkbook.ActiveSheet.Range("A" & OutputRow) =     ThisWorkbook.Name
            ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents
            OutputRow = OutputRow + 1

        Set Each ws In wb.Sheets
                ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = ws.Name
                ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents
                OutputRow = OutputRow + 1
            Next ws
            wb.Close SaveChanges:=False
    Next
End Sub

Answer 1

我看到你引用了Microsoft Scripting Runtime，所以我将跳过那部分。

简单解决方案：一个模块，以递归方式撤回文件夹和子文件夹中的所有工作簿，并将它们添加到集合中：

Public Sub ExtractAllWorkbooks(ByVal Addr As String, ByRef coll As Collection)
    DoEvents
    Dim objFSO As New FileSystemObject
    Dim objFile As File, objFolder As Folder, objSubFolder As Folder

    Set objFolder = objFSO.GetFolder(Addr)

    For Each objFile In objFolder.Files
        If Right(objFile.Name, 5) = ".xlsx" And Left(objFile.Name, 1) <> "~" Then
            Call addStringToCollection(objFile.Path, coll)
        End If
    Next

    For Each objSubFolder In objFolder.SubFolders
        Call ExtractAllWorkbooks(objSubFolder.Path, coll)
    Next
End Function


Public Sub addStringToCollection(stringToAdd As String, coll As Collection)
    Dim st As String
    For i = 1 To coll.Count
        st = coll.Item(i)
        If st = stringToAdd Then Exit Sub
    Next
coll.Add stringToAdd
End Sub

这样，您只需要在主模块中运行：

dim Coll as New Collection
Const Addr As String = "G:\EP\Projects\"
Call ExtractAllWorkbooks(Addr, Coll)

现在您应该在集合Coll中列出所有工作簿。只需打开它们并在其他地方撤回工作表的名称。假设您将结果导出到工作表wsRef：

，这样的事情应该可以解决问题

dim wb as Workbook, ws as Worksheet
i = 2
For each st in coll
    Set wb = Workbooks.Open(st)
    For Each ws in wb.Worksheets
        wsRef.Cells(i, 1) = wb.Name
        wsRef.Cells(i, 2) = ws.Name
        i = i + 1
    Next
    Application.DisplayAlerts = False
    wb.Close
    Application.DisplayAlerts = True
Next

宏以列出文件夹和子文件夹中的所有工作表

1 个答案: