'***************************************************************************************************
' 指定フォルダ内の全てのワークブックの全シートを印刷 Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/07/28(1.00)新規作成
'14/01/28(1.10)FolderPickerの共通モジュール変更
'20/02/29(1.11)*.xlsm化、他
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "指定フォルダ内の全てのワークブックの全シートを印刷"
Private Const g_cnsYen As String = "\"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :Button1_Click
'* 機能 :指定フォルダ内の全てのワークブックの全シートを印刷
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月27日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button1_Click()
'-----------------------------------------------------------------------------------------------
Dim strPathname As String ' フォルダ名(パス名)
Dim strFilename As String ' ファイル名
Dim swEsc As Boolean ' Escキー判定
'-----------------------------------------------------------------
' 「フォルダの参照」よりフォルダ名の取得(modFolderPicker2に収容)
strPathname = modFolderPicker2.FolderDialog("フォルダを指定して下さい", True)
' 未指定は終了
If strPathname = "" Then Exit Sub
' 指定フォルダ内のExcelワークブックのファイル名を参照する(1件目)
strFilename = Dir(strPathname & "\*.xl*", vbNormal) ' ←※①
' 検索ファイル無し
If strFilename = "" Then
MsgBox "このフォルダにはExcelワークブックは存在しません。", vbExclamation, g_cnsTitle
Exit Sub
End If
'-----------------------------------------------------------------
' 画面描画停止
With Application
.ScreenUpdating = False ' 画面描画停止
.EnableEvents = False ' イベント動作停止
.EnableCancelKey = xlErrorHandler ' Escキーでエラートラップする
.Cursor = xlWait ' カーソルを砂時計にする
End With
On Error GoTo Button1_Click_ERROR
'-----------------------------------------------------------------
' 指定フォルダの全Excelワークブックについて繰り返す
Do While strFilename <> ""
DoEvents
' Escキー打鍵判定
If swEsc Then
' 中断するのかをメッセージで確認
If MsgBox("中断キーが押されました。ここで終了しますか?", _
vbInformation + vbYesNo, g_cnsTitle) = vbYes Then
GoTo Button1_Click_EXIT
Else
swEsc = False
End If
End If
'-------------------------------------------------------------
' 1ファイル単位の処理
Call GP_AboutBookProc(strPathname, strFilename) ' ←※②
'-------------------------------------------------------------
' 次のファイル名を参照
strFilename = Dir ' ←※③
Loop
GoTo Button1_Click_EXIT
'===================================================================================================
' Escキー脱出用行ラベル
Button1_Click_ERROR:
' エラー内容判定
If Err.Number = 18 Then
' EscキーでのエラーRaise
swEsc = True
Resume
ElseIf Err.Number = 1004 Then
' 隠しシートや印刷対象なしの実行時エラーは無視
Resume Next
Else
' その他のエラーはメッセージ表示後終了
MsgBox Err.Description
End If
'===================================================================================================
' 処理終了
Button1_Click_EXIT:
With Application
.StatusBar = False ' ステータスバーを復帰
.EnableEvents = True ' イベント動作再開
.EnableCancelKey = xlInterrupt ' Escキー動作を戻す
.Cursor = xlDefault ' カーソルをデフォルトに戻す
.ScreenUpdating = True ' 画面描画再開
End With
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_AboutBookProc
'* 機能 :1つのワークブックの処理(このサンプルでは全シート印刷)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = フォルダ名(String)
'* Arg2 = ファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年07月27日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_AboutBookProc(ByVal strPathname As String, ByVal strFilename As String)
'-----------------------------------------------------------------------------------------------
Dim objWbk As Workbook ' ワークブックObject
Dim strFullname As String ' フルパスファイル名
' フルパスファイル名の編集
strFullname = strPathname & g_cnsYen & strFilename
' ステータスバーに処理ファイル名を表示
Application.StatusBar = strFilename & " 印刷中...."
' ワークブックを開く(このサンプルでは読み取り専用)
Set objWbk = Workbooks.Open(Filename:=strFullname, UpdateLinks:=False, ReadOnly:=True)
'-----------------------------------------------------------------
' ↓↓↓ 検索した1ファイル単位の処理 ↓↓↓
' 全シートを印刷
objWbk.PrintOut
'objWBK.PrintPreview ' ※お試し用(プレビュー)
' ↑↑↑ 検索した1ファイル単位の処理 ↑↑↑
'-----------------------------------------------------------------
' 開いたブックをClose(必要であれば保存して下さい)
objWbk.Close SaveChanges:=False
Set objWbk = Nothing
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
№ | 概略説明 |
---|---|
※① |
Dir関数で1件目のファイル名を受け取ります。
Dir関数に指定フォルダを渡す時に「\*.xl*"」を付加させているので、ほぼExcelワークブックが検索されます。 (完全な方法ではありません) |
※② |
検索された1ファイルに対する処理になります。 |
※③ |
次のファイル名を受け取ります。 |
'***************************************************************************************************
' 指定フォルダ内の全てのワークブックの全シートを印刷(FSO) Module2(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'20/02/29(1.00)新規作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "指定フォルダ内の全てのワークブックの全シートを印刷"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :Button1_Click
'* 機能 :指定フォルダ内の全てのワークブックの全シートを印刷
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2020年02月29日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button1_Click()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim cntFolder As Long ' フォルダ数カウンタ
Dim cntFile As Long ' ファイル数カウンタ
Dim cntBook As Long ' 対象ワークブック数カウンタ
Dim blnResult As Boolean ' 処理成否
Dim strRootFolder As String ' ルートフォルダ
'-----------------------------------------------------------------
' ルートとなるフォルダの指定(※modFolderPicker2.bas)
strRootFolder = modFolderPicker2.FolderDialog("ルートフォルダを指定して下さい。")
' 未指定は終了
If strRootFolder = "" Then Exit Sub
'-----------------------------------------------------------------
' 画面描画停止
With Application
.ScreenUpdating = False ' 画面描画停止
.EnableEvents = False ' イベント動作停止
.EnableCancelKey = xlErrorHandler ' Escキーでエラートラップする
.Cursor = xlWait ' カーソルを砂時計にする
End With
' 処理開始
Set objFso = New FileSystemObject
'-----------------------------------------------------------------
' ルートフォルダから探索開始
blnResult = FP_FolderProc(objFso, objFso.GetFolder(strRootFolder), cntFolder, cntFile, cntBook)
'-----------------------------------------------------------------
' 処理完了
Set objFso = Nothing
' 画面描画再開
With Application
.StatusBar = False ' ステータスバーを復帰
.EnableEvents = True ' イベント動作再開
.EnableCancelKey = xlInterrupt ' Escキー動作を戻す
.Cursor = xlDefault ' カーソルをデフォルトに戻す
.ScreenUpdating = True ' 画面描画再開
End With
' 結果表示
If blnResult Then
MsgBox "処理が完了しました。" & vbCr & vbCr & _
"フォルダ数=" & cntFolder & vbCr & _
"ファイル数=" & cntFile & vbCr & _
"処理ブック=" & cntBook, vbInformation
End If
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_FolderProc
'* 機能 :フォルダ単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数 :Arg1 = FileSystemObject(Object)
'* Arg2 = フォルダ(Object)
'* Arg3 = フォルダ数カウンタ(Long) ※Ref参照
'* Arg4 = ファイル数カウンタ(Long) ※Ref参照
'* Arg5 = 対象ワークブック数カウンタ(Long) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2020年02月29日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:本処理は再帰動作
'***************************************************************************************************
Private Function FP_FolderProc(ByRef objFso As FileSystemObject, _
ByVal objFolder As Folder, _
ByRef cntFolder As Long, _
ByRef cntFile As Long, _
ByRef cntBook As Long) As Boolean
'-----------------------------------------------------------------------------------------------
Dim objSubFolder As Folder ' サブフォルダ
Dim objFile As File ' ファイル
FP_FolderProc = False
cntFolder = cntFolder + 1 ' 参照フォルダ数を加算
'-----------------------------------------------------------------
' ■先ずサブフォルダを探索
For Each objSubFolder In objFolder.SubFolders
' フォルダ単位処理(再帰呼び出し)
If Not FP_FolderProc(objFso, objSubFolder, cntFolder, cntFile, cntBook) Then Exit Function
Next objSubFolder
'-----------------------------------------------------------------
On Error GoTo FolderProc_ERROR
' 処理フォルダを表示
Application.StatusBar = objFolder.Name & " 処理中...."
' ■本フォルダの各ファイルを探索
For Each objFile In objFolder.Files
cntFile = cntFile + 1 ' 参照ファイル数
' ファイル単位処理
Call GP_FileProc(objFso, objFile, cntBook)
Next objFile
FP_FolderProc = True
GoTo FolderProc_EXIT
'===================================================================================================
' 実行時エラー処理
FolderProc_ERROR:
' エラー内容判定
If Err.Number = 18 Then
' Escキー打鍵は終了確認
If MsgBox("中断キーが押されました。ここで終了しますか?", _
vbInformation + vbYesNo, g_cnsTitle) = vbYes Then
GoTo FolderProc_EXIT
Else
Resume
End If
ElseIf Err.Number = 1004 Then
' 隠しシートや印刷対象なしの実行時エラー等は無視
Resume Next
Else
' その他のエラーはメッセージ表示後終了
MsgBox Err.Description, vbCritical, g_cnsTitle
End If
'===================================================================================================
' 終了
FolderProc_EXIT:
' 参照Objectを破棄
Set objFolder = Nothing
On Error GoTo 0
End Function
'***************************************************************************************************
'* 処理名 :GP_FileProc
'* 機能 :ファイル単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = FileSystemObject(Object)
'* Arg2 = ファイル(Object)
'* Arg3 = 対象ワークブック数カウンタ(Long) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2020年02月29日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_FileProc(ByRef objFso As FileSystemObject, _
ByVal objFile As File, _
ByRef cntBook As Long)
'-----------------------------------------------------------------------------------------------
Dim strFullname As String ' フルパスファイル名
Dim strExtU As String ' 拡張子(大文字)
' 拡張子取得
strExtU = UCase(objFso.GetExtensionName(objFile.Name))
' 拡張子がExcelワークブックか判定
If ((strExtU = "XLS") Or (strExtU = "XLSX") Or (strExtU = "XLSM") Or (strExtU = "XLSB")) Then
cntBook = cntBook + 1 ' 参照ブック数
' ステータスバーに処理ファイル名を表示
Application.StatusBar = objFile.Name & " 処理中...."
strFullname = objFso.BuildPath(objFile.Path, objFile.Name)
' ワークブック単位処理
Call GP_AboutBookProc(strFullname)
End If
End Sub
'***************************************************************************************************
'* 処理名 :GP_AboutBookProc
'* 機能 :ワークブック単位処理(このサンプルでは全シート印刷)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = フルパスファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2020年02月29日
'* 作成者 :井上 治
'* 更新日 :2020年02月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_AboutBookProc(ByVal strFullname As String)
'-----------------------------------------------------------------------------------------------
Dim objWbk As Workbook ' ワークブックObject
' ワークブックを開く(このサンプルでは読み取り専用)
Set objWbk = Workbooks.Open(Filename:=strFullname, UpdateLinks:=False, ReadOnly:=True)
'-----------------------------------------------------------------
' ↓↓↓ 検索した1ファイル単位の処理 ↓↓↓
' 全シートを印刷
objWbk.PrintOut
'objWBK.PrintPreview ' ※お試し用(プレビュー)
' ↑↑↑ 検索した1ファイル単位の処理 ↑↑↑
'-----------------------------------------------------------------
' 開いたブックをClose(必要であれば保存して下さい)
objWbk.Close SaveChanges:=False
Set objWbk = Nothing
End Sub
'----------------------------------------<< End of Source >>----------------------------------------