-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
Option Explicit
Private Sub CommandButton1_Click()
'画面を更新しない
Application.ScreenUpdating = False
'確認メッセージを表示しない
Application.DisplayAlerts = False
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim strFolderPath As String
strFolderPath = ThisWorkbook.path & "\WORK"
'testフォルダがない場合、作成
If Dir(strFolderPath, vbDirectory) = "" Then
'テストフォルダ作成
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")
End If
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
strFolderPath = .SelectedItems(1)
End If
End With
'フォルダ配下のファイルを再帰的に取得
getFilesRecursive (strFolderPath)
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
MsgBox "処理完了"
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
If objFile.Name Like "*.xlsx" Then
Dim wb As Workbook
Dim sheet As Variant
Set wb = Workbooks.Open(objFile.path)
For Each sheet In wb.Worksheets
'A1選択
Application.Goto sheet.Range("A1")
Next sheet
'先頭シート選択
wb.Sheets(1).Select
'ワークブック保存
wb.Save
wb.Close
End If
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
Dim i As Long
i = 0
Do While i < addsheetnum
Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh.Name = "シート" & (Worksheets.Count)
i = i + 1
Loop
'全シートでB2セルを選択
Dim sheet As Variant
For Each sheet In wb.Worksheets
sheet.Activate
sheet.Cells(2, 2).Select
Next sheet
'ワークブックを保存して閉じる
wb.Close True, filepath
ThisWorkbook.Activate
End Sub
