フォルダ内のファイルをまとめて処理したいときに使えるマクロです。
全てそのままコピペしたら使えます。
処理の流れ
- 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
サブフォルダまで見る（保存無）
Rem 【主な用途】
Rem 指定したフォルダ内のすべてのファイルに関して何かの処理（値を集めるなど）をしたいときに利用します。
Rem 収集した値は出力用シート(outputWs)に書き出すことを想定しています。
Rem 変更の必要がある関数は以下の通りです。それ以外は修正する必要はありません。
Rem >ProcEachBook ⇒ ブック単位で処理したい場合
Rem >ProcEachSheet ⇒ シート単位で処理したい場合
Rem >CheckTargetBook ⇒ 処理対象ブックを絞りたい場合
Rem @note 「ユーザー定義型は定義されていません。」と出てきたら"Microsoft Scriptiong Runtime"を参照設定に追加します。
Rem @note ツール(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 errorLogCnt As Long
Dim errorWs As Worksheet
' 処理対象ファイル名を書きだすためのシート
Dim outputTargetWs As Worksheet
Dim targetWsCnt As Long
Rem メインの処理
Rem @note Excelからはこの関数を呼びましょう
Sub Main()
Dim strPath As String ' 選択したフォルダのパス
With Application.FileDialog(msoFileDialogFolderPicker) ' フォルダ選択ダイアログ
If .Show = True Then
If .SelectedItems(1) = "" Then ' フォルダが選択されなかった場合
MsgBox "フォルダを指定してください。"
Call Done
Exit Sub
Else
strPath = .SelectedItems(1)
End If
End If
End With
Call Init
' フォルダが選択されたら利用する変数の初期化
Set outputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
outputCnt = 1
errorLogCnt = 1
targetWsCnt = 1
' システム用シートの値を初期化
outputTargetWs.Cells.Clear
errorWs.Range("A2:AA" & errorWs.Cells(Rows.Count, 1).End(xlUp).Row).Clear
'メインの処理を呼び出す
Call DoInSubFolder(strPath)
Set outputWs = Nothing
Set errorWs = Nothing
Set outputTargetWs = Nothing
Call Done
MsgBox "処理が完了しました。"
End Sub
Rem 指定したフォルダ内のサブフォルダ内を含むファイルを処理する
Rem @note 「ユーザー定義型は定義されていません。」と出てきたら"Microsoft Scriptiong Runtime"を参照設定に追加します。
Rem @note ツール(T)＞参照設定(R)＞「Microsoft Scripting Runtime」
Private Sub DoInSubFolder(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 DoInSubFolder(objFolder.Path) '//サブフォルダを指定して再帰呼び出し
Next
'//フォルダ内のファイルパスを取得(自身以外のExcelブックを対象)
For Each objFile In fso.GetFolder(folderPath).Files
With objFile
If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
'Excelファイルであれば処理を行う
On Error Resume Next
Dim targetWbk As Workbook
Workbooks.Open .Path, UpdateLinks:=False
Set targetWbk = ActiveWorkbook
If Err.Number <> 0 Then
'エラーログに出力
errorLogCnt = errorLogCnt + 1
errorWs.Cells(errorLogCnt, 1).Value = .Path & "は開けませんでした。"
Else
On Error GoTo 0
'問題なくファイルを開けたら
If CheckTargetBook(.Name) = True Then
Call ProcEachBook(targetWbk)
End If
targetWbk.Close False
End If
Set targetWbk = Nothing
outputTargetWs.Cells(targetWsCnt, 1).Value = .Path
cntFile = cntFile + 1
End If
End With
Next
Set fso = Nothing
End Sub
Rem それぞれのブックに関する処理
Rem @note DoInSubFolderから呼ばれる
Sub ProcEachBook(wbk As Workbook)
'それぞれのワークブックの制御
Dim targetWs As Worksheet
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
' ブック単位に処理したい場合はここに処理を書く
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
For Each targetWs In wbk.Worksheets
Call ProcEachSheet(targetWs)
Set targetWs = Nothing
Next targetWs
End Sub
Rem それぞれのシートに関する処理
Rem @note ProcEachBookから呼ばれる
Sub ProcEachSheet(ws As Worksheet)
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'ここに各シートに対する処理を書く
'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox ws.Parent.Name & "::" & ws.Name
outputWs.Cells(targetWsCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
targetWsCnt = targetWsCnt + 1
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub
Rem 対象ブック名を絞り込むための関数
Rem @note 対象ブックを限定する場合記載
Private Function CheckTargetBook(fileName As String)
CheckTargetBook = True
'#############################
'例）ブック名に比較を含むとき処理対象とする場合
'#############################
' If InStr(fileName, "比較") = 0 Then
' CheckTargetBook = False
' Exit Function
' End If
'#############################
End Function
Rem 初期処理
Private Sub Init()
With Application
.Calculation = xlCalculationManual
'.EnableEvents = False
.ScreenUpdating = False
End With
'システム用のシートを作成する
Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
End Sub
Rem 終了処理
Private Sub Done()
With Application
.Calculation = xlCalculationAutomatic
'.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Rem ワークシートが存在することをチェックする関数
Rem @return As Boolean 存在していればTrue
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
Rem ワークシートを追加する関数
Rem @return As Boolean 問題なく追加できればTrue
Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
addWorkSheet = False
On Error GoTo wsCreateError
If isExistWorkSheet(wbk, sheetName) = False Then
Dim ws As Worksheet
Set ws = wbk.Worksheets.Add
ws.Name = sheetName
addWorkSheet = True
End If
Exit Function
wsCreateError:
addWorkSheet = False
End Function
Rem ワークシートを削除する関数
Rem @return As Boolean 問題なく削除できればTrue
Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
deleteWorkSheet = 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
Rem MIT License
Rem
Rem Copyright (c) 2020 uedive.net
Rem
Rem Permission is hereby granted, free of charge, to any person obtaining a copy
Rem of this software and associated documentation files (the "Software"), to deal
Rem in the Software without restriction, including without limitation the rights
Rem to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
Rem copies of the Software, and to permit persons to whom the Software is
Rem furnished to do so, subject to the following conditions:
Rem
Rem The above copyright notice and this permission notice shall be included in all
Rem copies or substantial portions of the Software.
Rem
Rem THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
Rem IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
Rem FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
Rem AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
Rem LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
Rem OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
Rem SOFTWARE.
コメント
[…] […]