定番のヘッダー、フッターの瞬時に設定。リボンに登録して使用すると便利
(Microsoft365 64bit環境推奨)
G-Tool1-A01 からのつづき
6.【Alt】+【F11】キーを押下し、VBE画面を出す。
7.【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
8.下記ボックス内をコピーし、標準モジュールに貼り付ける。
9.モジュール名を【M02_HeaderFooter】に変更する。
モジュール名:M02_HeaderFooter
Option Explicit '==================================================== ' 全シートにヘッダーフッターを設定 '==================================================== Sub AllH_F_YuG() Dim i As Long Dim Motioncnt As Long On Error GoTo AllH_F_YuG_Err If Bln_Err = False Then ErrProsName = "AlIH_F_YuG" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False With ActiveWorkbook For i = 1 To .Sheets.Count Motioncnt = Int((10 / Sheets.Count) * i) DoEvents Application.StatusBar = " (" & i & " " & .Sheets.Count & ")" & _ "を処理中・・・" & String(Motioncnt, "■") & _ String(10 - Motioncnt, "□") If Worksheets(i).Visible = False Then GoTo There End If Worksheets(i).Select With Worksheets(i).PageSetup .LeftHeader = "&"" Yu Gothic, 標準""&10&D" .CenterHeader = "&"" Yu Gothic, 太字""&12&A" .RightHeader = "&"" Yu Gothic, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Yu Gothic, 標準""&10&F" .RightFooter = "" End With There: Next i Application.StatusBar = "" End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If AllH_F_YuG_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub AllH_F_YuG_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo AllH_F_YuG_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 '==================================================== Sub SoloH_F_YuG() On Error GoTo SoloH_F_YuG_Err If Bln_Err = False Then ErrProsName = "SoloH_F_YuG" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Application.StatusBar = "" With ActiveSheet.PageSetup .LeftHeader = "&"" Yu Gothic, 標準""&10&D" .CenterHeader = "&"" Yu Gothic, 太字""&12&A" .RightHeader = "&"" Yu Gothic, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Yu Gothic, 標準""&10&F" .RightFooter = "" End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SoloH_F_YuG_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SoloH_F_YuG_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo SoloH_F_YuG_Exit End Sub '==================================================== ' 全シートにヘッダーフッターを設定 '==================================================== Sub AllH_F_MeiUI() Dim i As Long Dim Motioncnt As Long On Error GoTo AllH_F_MeiUI_Err If Bln_Err = False Then ErrProsName = "AlIH_F_YuG" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False With ActiveWorkbook For i = 1 To .Sheets.Count Motioncnt = Int((10 / Sheets.Count) * i) DoEvents Application.StatusBar = " (" & i & " " & .Sheets.Count & ")" & _ "を処理中・・・" & String(Motioncnt, "■") & _ String(10 - Motioncnt, "□") If Worksheets(i).Visible = False Then GoTo There End If Worksheets(i).Select With Worksheets(i).PageSetup .LeftHeader = "&"" Meiryo UI, 標準""&10&D" .CenterHeader = "&"" Meiryo UI, 太字""&12&A" .RightHeader = "&"" Meiryo UI, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Meiryo UI, 標準""&10&F" .RightFooter = "" End With There: Next i Application.StatusBar = "" End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If AllH_F_MeiUI_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub AllH_F_MeiUI_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo AllH_F_MeiUI_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 '==================================================== Sub SoloH_F_MeiUI() On Error GoTo SoloH_F_MeiUI_Err If Bln_Err = False Then ErrProsName = "SoloH_F_MeiUI" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Application.StatusBar = "" With ActiveSheet.PageSetup .LeftHeader = "&"" Meiryo UI, 標準""&10&D" .CenterHeader = "&"" Meiryo UI, 太字""&12&A" .RightHeader = "&"" Meiryo UI, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Meiryo UI, 標準""&10&F" .RightFooter = "" End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SoloH_F_MeiUI_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SoloH_F_MeiUI_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo SoloH_F_MeiUI_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 縦 MeiryoUI '==================================================== Sub SetMPortraite() On Error GoTo SetMPortraite_Err If Bln_Err = False Then ErrProsName = "SetMPortraite" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Call showStatus("シート設定") With ActiveSheet.PageSetup .LeftHeader = "&"" Meiryo UI, 標準""&10&D" .CenterHeader = "&"" Meiryo UI, 太字""&12&A" .RightHeader = "&"" Meiryo UI, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Meiryo UI, 標準""&10&F" .RightFooter = "" .Orientation = xlPortrait End With With ActiveSheet.Cells .Font.Name = "Meiryo UI" .Font.Size = 10 .RowHeight = 18.75 End With With ActiveSheet .Columns(1).ColumnWidth = 1.25 .Columns(2).ColumnWidth = 58 .Columns(2).WrapText = True .Columns(3).ColumnWidth = 1.25 End With Call showStatus("") '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SetMPortraite_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SetMPortraite_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo SetMPortraite_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 縦 Yu Gothic '==================================================== Sub SetYuPortraite() On Error GoTo SetYuPortraite_Err If Bln_Err = False Then ErrProsName = "SetYuPortraite" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Call showStatus("シート設定") With ActiveSheet.PageSetup .LeftHeader = "&"" Yu Gothic, 標準""&10&D" .CenterHeader = "&"" Yu Gothic, 太字""&12&A" .RightHeader = "&"" Yu Gothic, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Yu Gothic, 標準""&10&F" .RightFooter = "" .Orientation = xlPortrait End With With ActiveSheet.Cells .Font.Name = "Yu Gothic" .Font.Size = 10 .RowHeight = 18.75 End With With ActiveSheet .Columns(1).ColumnWidth = 1.25 .Columns(2).ColumnWidth = 58 .Columns(2).WrapText = True .Columns(3).ColumnWidth = 1.25 End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SetYuPortraite_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SetYuPortraite_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo SetYuPortraite_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 縦 MeiryoUI '==================================================== Sub SetMLandScape() On Error GoTo SetMLandScape_Err If Bln_Err = False Then ErrProsName = "SetMLandScape" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Application.StatusBar = "" With ActiveSheet.PageSetup .LeftHeader = "&"" Meiryo UI, 標準""&10&D" .CenterHeader = "&"" Meiryo UI, 太字""&12&A" .RightHeader = "&"" Meiryo UI, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Meiryo UI, 標準""&10&F" .RightFooter = "" .Orientation = xlLandscape End With With ActiveSheet.Cells .Font.Name = "Meiryo UI" .Font.Size = 10 .RowHeight = 18.75 End With With ActiveSheet .Columns(1).ColumnWidth = 1.25 .Columns(2).ColumnWidth = 88 .Columns(2).WrapText = True .Columns(3).ColumnWidth = 1.25 End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SetMLandScape_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SetMLandScape_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア GoTo SetMLandScape_Exit End Sub '==================================================== ' 単シートにヘッダーフッターを設定 縦 MeiryoUI '==================================================== Sub SetYuLandScape() On Error GoTo SetYuLandScape_Err If Bln_Err = False Then ErrProsName = "SetYuLandScape" If IsCall = False Then Call StopUpdating End If '//プリンタとの接続を切断 Application.PrintCommunication = False Application.StatusBar = "" With ActiveSheet.PageSetup .LeftHeader = "&"" Yu Gothic, 標準""&10&D" .CenterHeader = "&"" Yu Gothic, 太字""&12&A" .RightHeader = "&"" Yu Gothic, 標準""P. &P/&N" .LeftFooter = "" .CenterFooter = "&"" Yu Gothic, 標準""&10&F" .RightFooter = "" .Orientation = xlLandscape End With With ActiveSheet.Cells .Font.Name = "Yu Gothic" .Font.Size = 10 .RowHeight = 18.75 End With With ActiveSheet .Columns(1).ColumnWidth = 1.25 .Columns(2).ColumnWidth = 88 .Columns(2).WrapText = True .Columns(3).ColumnWidth = 1.25 End With '//プリンタを再接続 Application.PrintCommunication = True '最小化 If ActiveWorkbook.Name <> ThisWorkbook.Name Then Windows(ThisWorkbook.Name).WindowState = xlMinimized End If End If SetYuLandScape_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating 'エラー制御を戻す On Error GoTo 0 Exit Sub SetYuLandScape_Err: '【ESC】で止められた場合 If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then Call exeBreak Resume End If 'その他のエラー Else MsgBox "実行時エラー" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName End If Err.Clear 'エラー情報クリア Goto SetYuLandScape_Exit End Sub
コメント