フォルダ内のファイルをまとめて処理したいときに使えるマクロです。
全てそのままコピペしたら使えます。
処理の流れ
- Mainのサブモジュールを実行する
- 処理対象のフォルダを選択する
- 対象ファイルパスを対象ファイルシートに記載する
- 対象ファイルシートに記載されたブックを順に開く
- ブックに含まれるシートに対して処理関数を呼ぶ(DoYourMethod)
- シートに対する処理を行う(DoEverySheets)
- 4に戻る
プログラムの更新
選択したフォルダ内の全てのエクセルファイルに対して処理を行います。
DoEverySheetsでは各シートの処理を行います。引数にはワークシートオブジェクトがあり、読み込んだファイルにあるシートが渡されていきます。
各シートに対してしたい処理をここに記載してください。
例)シート名で分岐を行い、あるシートに対する処理を行わないなど
'ツール(T)>参照設定(R)>「Microsoft Scripting Runtime」
Public Const TARGETWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"
Public Const OUTPUTWSNAME As String = "出力"
Dim outputCnt As Long
Dim outputWs As Worksheet
Sub Main()
Dim outputTargetWs As Worksheet
Dim errorWs As Worksheet
Dim strPath As String ' 選択したフォルダのパス
Dim fso As Object ' FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim targetWbk As Workbook
Dim cntFile As Long
Dim cntBook As Long
Dim errorLogCnt As Long
'システム用のシートを作成する
If isExistWorkSheet(ThisWorkbook, TARGETWSNAME) = False Then
Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
End If
If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
End If
If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
End If
Set outputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
outputCnt = 1
cntFile = 1
errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
errorWs.Range("A2:AA" & errorLogCnt).Clear
With Application.FileDialog(msoFileDialogFolderPicker) ' フォルダ選択ダイアログ
If .Show = True Then
strPath = .SelectedItems(1)
End If
End With
If strPath = "" Then ' フォルダが選択されなかった場合
MsgBox "フォルダを指定してください。"
Call Done
Exit Sub
End If
Call Init
outputTargetWs.Cells.Clear
Set fso = New FileSystemObject
Set objFolder = fso.GetFolder(strPath)
For Each objFile In objFolder.Files
With objFile
If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
outputTargetWs.Cells(cntFile, 1).Value = .Path
cntFile = cntFile + 1
End If
End With
Next objFile
For cntBook = 1 To cntFile - 1
On Error Resume Next
Workbooks.Open outputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
Set targetWbk = ActiveWorkbook
If Err.Number <> 0 Then
'エラーログに出力
errorLogCnt = errorLogCnt + 1
errorWs.Cells(errorLogCnt, 1).Value = outputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
Else
On Error GoTo 0
'問題なくファイルを開けたら
Call DoYourMethod(targetWbk, cntBook)
targetWbk.Close False
End If
Set targetWbk = Nothing
Next cntBook
Set outputWs = Nothing
Call Done
MsgBox "処理が完了しました。"
End Sub
Sub DoYourMethod(wbk As Workbook, cntBook As Long)
'それぞれのワークブックの制御
Dim targetWs As Worksheet
For Each targetWs In wbk.Worksheets
Call DoEverySheets(targetWs)
Set targetWs = Nothing
Next targetWs
End Sub
' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'ここに各シートに対する処理を書く
'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox ws.Parent.Name & "::" & ws.Name
'outputWs.Cells(outputCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub
Sub Init()
With Application
.Calculation = xlCalculationManual
'.EnableEvents = False
.ScreenUpdating = False
End With
End Sub
Sub Done()
With Application
.Calculation = xlCalculationAutomatic
'.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Dim ws As Worksheet
isExistWorkSheet = False
For Each ws In wbk.Worksheets
If ws.Name = sheetName Then
isExistWorkSheet = True
Exit For
End If
Next ws
End Function
Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
addWorkSheet = False
On Error GoTo wsCreateError
Dim ws As Worksheet
Set ws = wbk.Worksheets.Add
ws.Name = sheetName
addWorkSheet = True
Exit Function
wsCreateError:
addWorkSheet = False
End Function
Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Delete Worksheet = False
On Error GoTo wsDeleteError
If isExistWorkSheet(wbk, sheetName) = True Then
With Application
.DisplayAlerts = False
wbk.Worksheets(sheetName).Delete
.DisplayAlerts = True
End With
End If
deleteWorkSheet = True
Exit Function
wsDeleteError:
deleteWorkSheet = False
End Function
保存ができるバージョン
'ツール(T)>参照設定(R)>「Microsoft Scripting Runtime」
Public Const OUTPUTWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"
'処理したファイルを保存したい場合 True
Public Const ISSAVEMODE As Boolean = True
'保存フォルダ名 このマクロがあるフォルダにここで設定したフォルダ名のフォルダを作ります
Public Const SAVEFOLDERNAME As String = "処理結果"
Sub Main()
Dim outputTargetWs As Worksheet
Dim errorWs As Worksheet
Dim strPath As String ' 選択したフォルダのパス
Dim fso As Object ' FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim targetWbk As Workbook
Dim cntFile As Long
Dim cntBook As Long
Dim errorLogCnt As Long
'システム用のシートを作成する
If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
End If
If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
End If
Set outputTargetWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
cntFile = 1
errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
errorWs.Range("A2:AA" & errorLogCnt).Clear
If ISSAVEMODE = True Then
'ファイルの保存先のパスを作成する
Dim savePath As String
savePath = ThisWorkbook.path & "\" & SAVEFOLDERNAME & "\" & Format(Now, "yyyymmddhhnn")
If Dir(savePath, vbDirectory) = "" Then
Call MakePath(savePath)
End If
End If
With Application.FileDialog(msoFileDialogFolderPicker) ' フォルダ選択ダイアログ
If .Show = True Then
strPath = .SelectedItems(1)
End If
End With
If strPath = "" Then ' フォルダが選択されなかった場合
MsgBox "フォルダを指定してください。"
Call Done
Exit Sub
End If
Call Init
outputTargetWs.Cells.Clear
Set fso = New FileSystemObject
Set objFolder = fso.GetFolder(strPath)
For Each objFile In objFolder.Files
With objFile
If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
outputTargetWs.Cells(cntFile, 1).Value = .path
cntFile = cntFile + 1
End If
End With
Next objFile
For cntBook = 1 To cntFile - 1
On Error Resume Next
Workbooks.Open outputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
Set targetWbk = ActiveWorkbook
If Err.Number <> 0 Then
'エラーログに出力
errorLogCnt = errorLogCnt + 1
errorWs.Cells(errorLogCnt, 1).Value = outputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
Else
On Error GoTo 0
'問題なくファイルを開けたら
Call DoYourMethod(targetWbk, cntBook)
Call SaveWorkbook(targetWbk, savePath)
targetWbk.Close False
End If
Set targetWbk = Nothing
Next cntBook
Call Done
MsgBox "処理が完了しました。"
End Sub
Sub DoYourMethod(wbk As Workbook, cntBook As Long)
'それぞれのワークブックの制御
Dim targetWs As Worksheet
For Each targetWs In wbk.Worksheets
Call DoEverySheets(targetWs)
Set targetWs = Nothing
Next targetWs
End Sub
' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'ここに各シートに対する処理を書く
'MsgBox ws.Parent.Name & "::" & ws.Name
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub
Sub Init()
With Application
.Calculation = xlCalculationManual
'.EnableEvents = False
.ScreenUpdating = False
End With
End Sub
Sub Done()
With Application
.Calculation = xlCalculationAutomatic
'.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Dim ws As Worksheet
isExistWorkSheet = False
For Each ws In wbk.Worksheets
If ws.Name = sheetName Then
isExistWorkSheet = True
Exit For
End If
Next ws
End Function
Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
addWorkSheet = False
On Error GoTo wsCreateError
Dim ws As Worksheet
Set ws = wbk.Worksheets.Add
ws.Name = sheetName
addWorkSheet = True
Exit Function
wsCreateError:
addWorkSheet = False
End Function
Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Delete Worksheet = False
On Error GoTo wsDeleteError
If isExistWorkSheet(wbk, sheetName) = True Then
With Application
.DisplayAlerts = False
wbk.Worksheets(sheetName).Delete
.DisplayAlerts = True
End With
End If
deleteWorkSheet = True
Exit Function
wsDeleteError:
deleteWorkSheet = False
End Function
'再帰関数
Sub MakePath(path As String)
Dim parentFolder As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
parentFolder = fso.GetParentFolderName(path)
If Not fso.FolderExists(parentFolder) Then
Call MakePath(parentFolder)
Else
fso.CreateFolder path
Exit Sub
End If
fso.CreateFolder path
Set fso = Nothing
End Sub
Sub SaveWorkbook(wbk As Workbook, savePath As String)
If ISSAVEMODE = True Then
Application.DisplayAlerts = False
wbk.SaveAs (savePath & "\" & wbk.Name)
Application.DisplayAlerts = True
End If
End Sub
サブフォルダまで見る(保存無)
'ツール(T)>参照設定(R)>「Microsoft Scripting Runtime」
Public Const TARGETWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"
Public Const OUTPUTWSNAME As String = "出力"
Dim outputCnt As Long
Dim outputWs As Worksheet
Dim inputTargetWs As Worksheet
Dim cntFile As Long
Sub Main()
Dim errorWs As Worksheet
Dim strPath As String ' 選択したフォルダのパス
Dim fso As Object ' FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim targetWbk As Workbook
Dim cntBook As Long
Dim errorLogCnt As Long
'システム用のシートを作成する
If isExistWorkSheet(ThisWorkbook, TARGETWSNAME) = False Then
Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
End If
If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
End If
If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
End If
Set inputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
outputCnt = 1
cntFile = 1
errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
errorWs.Range("A2:AA" & errorLogCnt).Clear
With Application.FileDialog(msoFileDialogFolderPicker) ' フォルダ選択ダイアログ
If .Show = True Then
strPath = .SelectedItems(1)
End If
End With
If strPath = "" Then ' フォルダが選択されなかった場合
MsgBox "フォルダを指定してください。"
Call Done
Exit Sub
End If
Call Init
inputTargetWs.Cells.Clear
Call getFile(strPath)
For cntBook = 1 To cntFile - 1
On Error Resume Next
Workbooks.Open inputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
Set targetWbk = ActiveWorkbook
If Err.Number <> 0 Then
'エラーログに出力
errorLogCnt = errorLogCnt + 1
errorWs.Cells(errorLogCnt, 1).Value = inputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
Else
On Error GoTo 0
'問題なくファイルを開けたら
Call DoYourMethod(targetWbk, cntBook)
targetWbk.Close False
End If
Set targetWbk = Nothing
Next cntBook
Set outputWs = Nothing
Set inputTargetWs = Nothing
Call Done
MsgBox "処理が完了しました。"
End Sub
'対象ブック名を絞り込むための関数
'サブフォルダからファイル名を取得する際に呼ばれる。
'TODO 対象ファイルを限定する場合記載
Private Function checkTargetBook(fileName As String)
checkTargetBook = True
'#############################
'例)比較を含むファイルを対象にする
'#############################
' If InStr(fileName, "比較") = 0 Then
' checkTargetBook = False
' Exit Function
' End If
'#############################
End Function
'//サブフォルダ含めてすべてのファイルを操作
Private Sub getFile(folderPath As String)
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim objFolder As Folder
Dim objFile As File
'//すべてのフォルダを操作
For Each objFolder In fso.GetFolder(folderPath).SubFolders
Call getFile(objFolder.Path) '//サブフォルダを指定して再帰呼び出し
Next
'//フォルダ内のファイルパスを取得(自身以外のExcelブックを対象)
For Each objFile In fso.GetFolder(folderPath).Files
With objFile
If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
If checkTargetBook(.Name) = True Then
inputTargetWs.Cells(cntFile, 1).Value = .Path
cntFile = cntFile + 1
End If
End If
End With
Next
Set fso = Nothing
End Sub
Sub DoYourMethod(wbk As Workbook, cntBook As Long)
'それぞれのワークブックの制御
Dim targetWs As Worksheet
For Each targetWs In wbk.Worksheets
Call DoEverySheets(targetWs)
Set targetWs = Nothing
Next targetWs
End Sub
' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'ここに各シートに対する処理を書く
'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox ws.Parent.Name & "::" & ws.Name
'outputWs.Cells(outputCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub
Sub Init()
With Application
.Calculation = xlCalculationManual
'.EnableEvents = False
.ScreenUpdating = False
End With
End Sub
Sub Done()
With Application
.Calculation = xlCalculationAutomatic
'.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Dim ws As Worksheet
isExistWorkSheet = False
For Each ws In wbk.Worksheets
If ws.Name = sheetName Then
isExistWorkSheet = True
Exit For
End If
Next ws
End Function
Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
addWorkSheet = False
On Error GoTo wsCreateError
Dim ws As Worksheet
Set ws = wbk.Worksheets.Add
ws.Name = sheetName
addWorkSheet = True
Exit Function
wsCreateError:
addWorkSheet = False
End Function
Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
Delete Worksheet = False
On Error GoTo wsDeleteError
If isExistWorkSheet(wbk, sheetName) = True Then
With Application
.DisplayAlerts = False
wbk.Worksheets(sheetName).Delete
.DisplayAlerts = True
End With
End If
deleteWorkSheet = True
Exit Function
wsDeleteError:
deleteWorkSheet = False
End Function
コメント
[…] […]