VBA(再帰的にフォルダ内全ファイルのシート一覧を作成する)

https://vba-labo.rs-techdev.com/archives/30
https://kirinote.com/excelvba-lastrow-del/#toc2

test--|Dir01--|File0101(シート1,2)
      |       |Dir0102--|File010201(シート1)
      |       |         |File010202(シート1,2,3)
      |       |Dir0103
      |File02(シート1,2,3)

-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する

-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行

Option Explicit

Dim i As Long

Dim linenum As Long

Private Sub CommandButton1_Click()

    '画面を更新しない
    Application.ScreenUpdating = False
    '確認メッセージを表示しない
    Application.DisplayAlerts = False
    
    linenum = 10

    '10行目以下をクリア
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Rows("10:" & LastRow).Delete
    
    'ヘッダー記載
    With ThisWorkbook.Worksheets("sheet1")
        .Cells(linenum, 2).Value = "ファイル名"
        .Cells(linenum, 3).Value = "シート名"
    End With
    linenum = linenum + 1
    
    
    
    'testフォルダがあったら削除
    
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Dim strFolderPath As String
    strFolderPath = ThisWorkbook.path & "\test"
    
    If Dir(strFolderPath, vbDirectory) <> "" Then
        objFSO.DeleteFolder strFolderPath
    End If
    
    'テストフォルダ作成
    MkDir strFolderPath
    MkDir strFolderPath & "\Dir01"
    MkDir strFolderPath & "\Dir01\Dir0102"
    MkDir strFolderPath & "\Dir01\Dir0103"
    
    
    'テストファイル作成
    Call createFile(2, strFolderPath & "\File02.xlsx")
    Call createFile(1, strFolderPath & "\Dir01\File0101.xlsx")
    Call createFile(0, strFolderPath & "\Dir01\Dir0102\File010201.xlsx")
    Call createFile(2, strFolderPath & "\Dir01\Dir0102\File010202.xlsx")

    'フォルダ配下のファイル一覧を再帰的に取得
    getFilesRecursive (strFolderPath)
    
    
    '確認メッセージを表示する
    Application.DisplayAlerts = True
    '画面を更新する
    Application.ScreenUpdating = True

End Sub

Private Sub getFilesRecursive(path As String)
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    

    Dim objFolder As Variant
    Dim objFile As Variant
    
    For Each objFolder In objFSO.GetFolder(path).SubFolders
        Call getFilesRecursive(objFolder.path)
    Next objFolder
    
    For Each objFile In objFSO.GetFolder(path).Files
        
        Dim wb As Workbook
        Dim sh As Worksheet
        Dim sheet As Object

        Set wb = Workbooks.Open(objFile.path)
        For Each sheet In wb.Worksheets
            Set sh = sheet
            With ThisWorkbook.Worksheets("sheet1")
                .Cells(linenum, 2).Value = objFile.path
                .Cells(linenum, 3).Value = sh.Name
            End With
            linenum = linenum + 1
    
        Next sheet
        wb.Close
    Next objFile

End Sub

'ファイル作成関数
Private Sub createFile(addsheetnum As Long, filepath As String)
    'ワークブック作成
    Dim wb As Workbook
    Set wb = Workbooks.Add
    
    'シート名取得
    Dim sheetName As String
    sheetName = Worksheets(1).Name
    
    'シート名変更
    Worksheets(1).Name = "シート1"
   
    'シート追加
    Dim sh As Worksheet
    
    i = 0
    Do While i < addsheetnum
        Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        sh.Name = "シート" & (Worksheets.Count)
        i = i + 1
    Loop
    

    'ワークブック保存
    wb.SaveAs (filepath)
    
    'ワークブックを閉じる
    wb.Close
 
End Sub