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
コメント