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