マクロを使用してフォルダとサブフォルダ内のすべてのワークシートを一覧表示する

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