行高調整関連コード。QATやリボンに登録して使用すると便利
（Microsoft365 64bit環境推奨）
New Base Macro Book をコピーしてモジュールを追加して使用します
- 【Alt】＋【F11】キーを押下し、VBE画面を出す。
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【G01_SetShtFmt_HF】に変更する。
モジュール名：G01_SetShtFmt_HF
Option Explicit
Private Const DEPARTMENT_NAME As String = "作成部署名"
Private Const AUTHOR_NAME As String = "作成者"
'+++*********************************************************+++
' B列基準: アクティブセル以下最終行まで行高調整
'+++*********************************************************+++
Sub AdjustRowHeightSmart()
Dim ws As Worksheet
Dim R As Long
Dim startRow As Long
Dim endRow As Long
Dim baseHeight As Double
Dim newHeight As Double
Dim rowRange As Range
Set ws = ActiveSheet
startRow = ActiveCell.Row
'再計算なしで保存
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
'UsedRangeから最終行を取得（信頼性注意）
With ws.UsedRange
endRow = .Rows(.Rows.Count).Row
End With
Call StopUpdating
For R = startRow To endRow
Set rowRange = ws.Rows(R)
'図形がかかっている行はスキップ
If HasShapeOnRow(ws, R) Then GoTo SkipRow
'B列が空白なら狭く
If IsEmpty(ws.Cells(R, 2)) Then
rowRange.RowHeight = 2.5
Else
'AutoFit → ゆとりを持たせて調整
rowRange.AutoFit
baseHeight = rowRange.RowHeight
newHeight = baseHeight * 1.45
rowRange.RowHeight = newHeight
End If
SkipRow:
Next R
Call Updating
MsgBox "行高を調整しました！", vbInformation
End Sub
'+++*********************************************************+++
' 使用範囲基準: アクティブセル以下最終行まで行高調整
'+++*********************************************************+++
Sub AdjustRowHeight_UsedRangeVer()
Dim ws As Worksheet
Dim R As Long
Dim startRow As Long
Dim endRow As Long
Dim baseHeight As Double
Dim newHeight As Double
Dim rowRange As Range
Dim MaxCol As Long
Set ws = ActiveSheet
startRow = ActiveCell.Row
'再計算なしで保存
Application.CalculateBeforeSave = False
ActiveWorkbook.Save
Call StopUpdating
'UsedRangeから最終行・最終列を取得
With ws.UsedRange
endRow = .Rows(.Rows.Count).Row
MaxCol = .Columns(.Columns.Count).Column
End With
For R = startRow To endRow
Set rowRange = ws.Range(ws.Cells(R, 1), ws.Cells(R, MaxCol))
'図形がかかっている行はスキップ
If HasShapeOnRow(ws, R) Then GoTo SkipRow
'COUNTAで空白判定
If WorksheetFunction.CountA(rowRange) = 0 Then
rowRange.EntireRow.RowHeight = 2.5
Else
rowRange.EntireRow.AutoFit
baseHeight = rowRange.EntireRow.RowHeight
newHeight = baseHeight * 1.45
rowRange.RowHeight = newHeight
End If
SkipRow:
Next R
Call Updating
MsgBox "行高を調整しました！（UsedRangeベースVer.）", vbInformation
End Sub
'***=========================================================***
' 図形がかかっているか判定する関数
'--- 指定行に図形が重なっているかを判定する ---
' 判定方法：図形の上下座標が行の範囲と交差しているか
'***=========================================================***
Function HasShapeOnRow(ws As Worksheet, targetRow As Long) As Boolean
Dim shp As Shape
Dim topY As Double, bottomY As Double
Dim rowTop As Double, rowBottom As Double
rowTop = ws.Rows(targetRow).Top
rowBottom = rowTop + ws.Rows(targetRow).Height
HasShapeOnRow = False
For Each shp In ws.Shapes
topY = shp.Top
bottomY = shp.Top + shp.Height
If bottomY > rowTop And topY < rowBottom Then
HasShapeOnRow = True
Exit Function
End If
Next shp
End Function
'+++*********************************************************+++
' テーブル内のデータの行高にゆとりを持たせる
'+++*********************************************************+++
Sub OptimizeRowHeightWithPadding()
Dim R As Long
Dim lo As ListObject
Dim rngRow As Range
Dim setHeight As Double
Dim baseHeight As Double
Dim newHeight As Double
Dim ws As Worksheet
Set ws = ActiveSheet
setHeight = 14
'最初のテーブルを対象（必要に応じて変更可）
If ws.ListObjects.Count = 0 Then
MsgBox "テーブルが見つかりません", vbExclamation
Exit Sub
End If
Call StopUpdating
Set lo = ws.ListObjects(1)
'データ行に対して処理
For R = lo.DataBodyRange.Row To lo.DataBodyRange.Row + lo.DataBodyRange.Rows.Count - 1
Set rngRow = ws.Rows(R)
rngRow.Rows.AutoFit
baseHeight = rngRow.RowHeight
If baseHeight * 1.1 - baseHeight < setHeight Then
newHeight = baseHeight + setHeight
Else
newHeight = baseHeight * 1.1
End If
rngRow.RowHeight = newHeight
Next R
Call Updating
MsgBox "行高を最適化＋余裕を持たせて再設定しました！", vbInformation
End Sub
'+++*********************************************************+++
' 新しいシートを追加し、初期レイアウトを整える（A4縦）
'+++*********************************************************+++
Sub exeAddSht()
Dim wsNew As Worksheet
'=== 画面更新停止（儀式）===
Call StopUpdating
'=== 新しいシートを追加（アクティブシートの後）===
Set wsNew = Sheets.Add(After:=ActiveSheet)
With wsNew
.Cells.VerticalAlignment = xlCenter
Call SetSheetFormat_HF(True) ' A4縦レイアウトで整える
End With
'=== 画面更新再開（儀式）===
Call Updating
End Sub
'+++*********************************************************+++
' ヘッダー・フッター設定関数
' テーマフォント基準で、列幅・行高を整える
' 引数：isPortrait（True:縦 / False:横）
' 使用例：Call SetSheetFormat_HF(True)
'+++*********************************************************+++
Sub SetSheetFormat_HF(isPortrait As Boolean)
Const MARGIN_PORTRAIT_CM As Double = 1.2
Const MARGIN_LANDSCAPE_CM As Double = 1.2
Const SIDE_WIDTH As Double = 0.8
Const BASE_MARGIN_CM As Double = 1.2
Const LANDSCAPE_ADJUST As Double = 0
Dim ActSht As Worksheet
Dim fontName As String
Dim centerWidth As Double
Dim leftRightMargin As Double
Dim widthAdjust As Double
Dim baseValue As Double
Dim adjustFactor As Double
Set ActSht = ActiveSheet
Application.PrintCommunication = False
'=== ページ設定 ===
leftRightMargin = IIf(isPortrait, MARGIN_PORTRAIT_CM, MARGIN_LANDSCAPE_CM)
widthAdjust = IIf(isPortrait, 0, LANDSCAPE_ADJUST)
With ActSht.PageSetup
.Orientation = IIf(isPortrait, xlPortrait, xlLandscape)
.PaperSize = xlPaperA4
.LeftMargin = Application.CentimetersToPoints(leftRightMargin)
.RightMargin = Application.CentimetersToPoints(leftRightMargin)
End With
'=== フォントサイズと配置 ===
With ActSht.Cells
.Font.Size = 10
.VerticalAlignment = xlCenter
End With
'=== タイトル設定 ===
With ActSht.Cells(2, 2)
If .Value = "" Then .Value = "タイトル"
.Font.Size = 16
End With
'=== フォント名取得 ===
fontName = ActSht.Cells(2, 2).Font.Name
'=== フォントごとの補正値設定 ===
Select Case fontName
Case "BIZ UDPGothic", "BIZ UDPゴシック"
If isPortrait Then
baseValue = 58.66: adjustFactor = -7.08
Else
baseValue = 87.27: adjustFactor = -5.93
End If
Case "Yu Gothic", "游ゴシック"
If isPortrait Then
baseValue = 80.06: adjustFactor = -7.53
Else
baseValue = 123.18: adjustFactor = -10.09
End If
Case "Meiryo UI", "メイリオ"
If isPortrait Then
baseValue = 73: adjustFactor = 0
Else
baseValue = 109: adjustFactor = 0
End If
Case "MS Pゴシッグ", "ＭＳ Ｐゴシック"
If isPortrait Then
baseValue = 89: adjustFactor = 0
Else
baseValue = 135: adjustFactor = 0
End If
Case Else
baseValue = IIf(isPortrait, 60, 75)
adjustFactor = 5
End Select
'=== centerWidth 計算 ===
centerWidth = baseValue + (leftRightMargin - BASE_MARGIN_CM) * adjustFactor + widthAdjust
'=== ヘッダー・フッター設定 ===
Call SetHeaderFooter(ActSht.PageSetup, fontName)
With ActSht
'=== 行高設定 ===
.Rows(1).RowHeight = 4.5
.Rows(2).RowHeight = 23
.Rows(3).RowHeight = 4.5
.Rows("4:" & .Rows.Count).RowHeight = 18.5
'=== 列幅設定 ===
.Columns(1).ColumnWidth = SIDE_WIDTH
.Columns(2).ColumnWidth = centerWidth
.Columns(2).WrapText = True
.Columns(3).ColumnWidth = SIDE_WIDTH
.Columns("A:C").Select
End With
Application.PrintCommunication = True
'=== 1ページに収める設定 ===
With ActSht.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintArea = "$A:$C" '印刷範囲を A:C に設定
End With
ActSht.Cells(2, 2).Select
MsgBox "テーマフォント：" & fontName & vbCrLf & _
"centerWidth = " & Round(centerWidth, 1) & vbCrLf & _
"余白：" & leftRightMargin & "cm × 2" & vbCrLf & _
"レイアウト：" & IIf(isPortrait, "縦", "横"), vbInformation
End Sub
'+++*********************************************************+++
' 悪名高き方眼用紙作成
' テーマフォント基準で、列幅・行高を整える
' 引数：isPortrait（True：縦 / False：横）
' 使用例：Call SetSheetFormat_GridStyle(True) 'A4縦方眼用紙
'+++*********************************************************+++
Sub SetSheetFormat_GridStyle(isPortrait As Boolean)
'=== 定数定義 ===
Const MARGIN_PORTRAIT_CM As Double = 1.2
Const MARGIN_LANDSCAPE_CM As Double = 1.6
Const SIDE_WIDTH As Double = 0.8
Const BASE_MARGIN_CM As Double = 1.2
Const GRID_WIDTH As Double = 2.4
Const PORTRAIT_ADJUST As Double = -10
Const LANDSCAPE_ADJUST As Double = -15
Dim ActSht As Worksheet
Dim fontName As String
Dim centerWidth As Double
Dim leftRightMargin As Double
Dim widthAdjust As Double
Dim baseValue As Double
Dim adjustFactor As Double
Dim colCount As Long
Dim i As Long
Set ActSht = ActiveSheet
Application.PrintCommunication = False
'=== 余白と補正値 ===
leftRightMargin = IIf(isPortrait, MARGIN_PORTRAIT_CM, MARGIN_LANDSCAPE_CM)
widthAdjust = IIf(isPortrait, PORTRAIT_ADJUST, LANDSCAPE_ADJUST)
'=== ページ設定 ===
With ActSht.PageSetup
.Orientation = IIf(isPortrait, xlPortrait, xlLandscape)
.PaperSize = xlPaperA4
.LeftMargin = Application.CentimetersToPoints(leftRightMargin)
.RightMargin = Application.CentimetersToPoints(leftRightMargin)
End With
'=== フォントサイズと折り返しなし ===
With ActSht.Cells
.Font.Size = 10
.WrapText = False
.VerticalAlignment = xlCenter
End With
'=== タイトル設定 ===
With ActSht.Cells(2, 2)
If .Value = "" Then .Value = "タイトル"
.Font.Size = 16
End With
'=== フォント名取得 ===
fontName = ActSht.Cells(2, 2).Font.Name
'=== 補正値設定 ===
Select Case fontName
Case "BIZ UDPGothic", "BIZ UDPゴシック"
If isPortrait Then
baseValue = 58.66: adjustFactor = -7.08
Else
baseValue = 87.27: adjustFactor = -5.93
End If
Case "Yu Gothic", "游ゴシック"
If isPortrait Then
baseValue = 80.06: adjustFactor = -7.53
Else
baseValue = 123.18: adjustFactor = -10.09
End If
Case "Meiryo UI", "メイリオ"
If isPortrait Then
baseValue = 73: adjustFactor = 0
Else
baseValue = 109: adjustFactor = 0
End If
Case "MS Pゴシック", "ＭＳ Ｐゴシック"
If isPortrait Then
baseValue = 89: adjustFactor = 0
Else
baseValue = 135: adjustFactor = 0
End If
Case Else
baseValue = IIf(isPortrait, 60, 75)
adjustFactor = 5
End Select
'=== centerWidth 計算 ===
centerWidth = baseValue + (leftRightMargin - BASE_MARGIN_CM) * adjustFactor - SIDE_WIDTH * 2 + widthAdjust
'=== ヘッダー・フッター設定 ===
Call SetHeaderFooter(ActSht.PageSetup, fontName)
'=== 行高設定 ===
With ActSht
.Rows(1).RowHeight = 4.5
.Rows(2).RowHeight = 23
.Rows(3).RowHeight = 4.5
.Rows("4:" & .Rows.Count).RowHeight = 18.5
End With
'=== 列幅設定（中央列を方眼風に分割）===
With ActSht
colCount = Int(centerWidth / GRID_WIDTH)
.Columns(1).ColumnWidth = SIDE_WIDTH '左サイド
For i = 2 To colCount + 1
.Columns(i).ColumnWidth = GRID_WIDTH
Next i
.Columns(colCount + 2).ColumnWidth = SIDE_WIDTH '右サイド
'=== 印刷範囲とページ設定 ===
.PageSetup.PrintArea = Range("A1", .Cells(.Rows.Count, colCount + 2)).Address
With .PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
End With
Application.PrintCommunication = True
ActSht.Cells(2, 2).Select
'=== 完了メッセージ ===
MsgBox "テーマフォント：" & fontName & vbCrLf & _
"centerWidth = " & Round(centerWidth, 1) & vbCrLf & _
"余白：" & leftRightMargin & "cm × 2" & vbCrLf & _
"レイアウト：" & IIf(isPortrait, "縦", "横"), vbInformation
End Sub
'+++*********************************************************+++
' 悪名高き方眼用紙作成（センター列数30固定Ver）
' テーマフォント基準で、列幅・行高を整える
' 引数：isPortrait（True：縦 / False：横）
' 使用例：Call SetSheetFormat_GridStyle30(True) 'A4縦方眼用紙
'+++*********************************************************+++
Sub SetSheetFormat_GridStyle30(isPortrait As Boolean)
Dim ActSht As Worksheet
Dim fontName As String
Dim sideWidth As Double: sideWidth = 0.8
Dim gridWidth As Double: gridWidth = 2.4
Dim colCount As Long: colCount = 30
Dim i As Long
Set ActSht = ActiveSheet
'=== タイトル設定（B2セル）===
With ActSht.Cells(2, 2)
If .Value = "" Then .Value = "タイトル"
.Font.Size = 16
End With
'=== フォント名取得（B2から）===
fontName = ActSht.Cells(2, 2).Font.Name
'=== シート全体のフォント設定 ===
With ActSht.Cells
.Font.Size = 10
.Font.Name = fontName
.WrapText = False
.VerticalAlignment = xlCenter
End With
'=== ヘッダー・フッター設定 ===
Call SetHeaderFooter(ActSht.PageSetup, fontName)
'=== ページ設定 ===
With ActSht.PageSetup
.Orientation = IIf(isPortrait, xlPortrait, xlLandscape)
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
'=== 行高設定 ===
With ActSht
.Rows(1).RowHeight = 4.5
.Rows(2).RowHeight = 23
.Rows(3).RowHeight = 4.5
.Rows("4:" & .Rows.Count).RowHeight = 18.5
End With
'=== 列幅設定（方眼用紙スタイル）===
With ActSht
.Columns(1).ColumnWidth = sideWidth 'A列（左サイド）
For i = 2 To colCount + 1
With .Columns(i)
.ColumnWidth = gridWidth
.Font.Name = fontName
End With
Next i
.Columns(colCount + 2).ColumnWidth = sideWidth '右サイド
End With
'=== 完了メッセージ ===
MsgBox "方眼用紙レイアウトを設定しました！" & vbCrLf & _
"テーマフォント：" & fontName & vbCrLf & _
"列数：" & colCount & vbCrLf & _
"レイアウト：" & IIf(isPortrait, "縦", "横"), vbInformation
End Sub
'***=========================================================***
' ヘッダー・フッター設定関数
' 指定フォントで､全体の印刷情報を整える
' ヘッダー：左日付 / 中央ーシート名 / 右=ページ番号
' フッター：中央＝ファイル名 / 左=（部署名＋作成者）※未使用
' 引数:PageSetupオブジェクト, フォント名
' 使用例：Call SetHeaderFooter(Activesheet.PageSetup，"Yu Gothic")
'***=========================================================***
Function SetHeaderFooter(ps As PageSetup, fontName As String)
With ps
.LeftHeader = "&"" " & fontName & ", 標準""&10&D"
.CenterHeader = "&"" " & fontName & ", 太字""&12&A"
.RightHeader = "&"" " & fontName & ", 標準""P. &P/&N"
'.LeftFooter = "&"" " & fontName & ", 標準""&10" & DEPARTMENT_NAME & vbLf & AUTHOR_NAME
.LeftFooter = ""
.CenterFooter = "&"" " & fontName & ", 標準""&10&F"
.RightFooter = ""
End With
End Function
'+++*********************************************************+++
' 全シートに Yu Gothic のヘッダー・フッターを設定
' 対象:全シート（非表示は除外）
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub AllH_F_YuG()
Dim i As Long
Application.PrintCommunication = False
For i = 1 To ActiveWorkbook.Sheets.Count
If Worksheets(i).Visible Then
Call SetHeaderFooter(Worksheets(i).PageSetup, "Yu Gothic")
End If
Next i
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' アクティブシートに Yu Gothic のヘッダー・フッターを設定
' 対象:単シート
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub SoloH_F_YuG()
Application.PrintCommunication = False
Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 全シートに BIZ UDPゴシックのヘッダー・フッターを設定
' 対象:全シート（非表示は除外）
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub AllH_F_BIZUDP()
Dim i As Long
Application.PrintCommunication = False
For i = 1 To ActiveWorkbook.Sheets.Count
If Worksheets(i).Visible Then
Call SetHeaderFooter(Worksheets(i).PageSetup, "BIZ UDPゴシック")
End If
Next i
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' アクティブシートに BIZ UDPゴシックのヘッダー・フッターを設定
' 対象:単シート
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub SoloH_F_BIZUDP()
Application.PrintCommunication = False
Call SetHeaderFooter(ActiveSheet.PageSetup, "BIZ UDPゴシック")
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 全シートに Meiryo UI のヘッダー・フッターを設定
' 対象:全シート（非表示は除外）
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub AllH_F_MeiUI()
Dim i As Long
Application.PrintCommunication = False
For i = 1 To ActiveWorkbook.Sheets.Count
If Worksheets(i).Visible Then
Call SetHeaderFooter(Worksheets(i).PageSetup, "Meiryo UI")
End If
Next i
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' アクティブシートに Meiryo UI のヘッダー・フッターを設定
' 対象:単シート
' 書式設定なし（印刷情報のみ）
'+++*********************************************************+++
Sub SoloH_F_MeiUI()
Application.PrintCommunication = False
Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
Application.PrintCommunication = True
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' テーマのフォント／縦向き／書式あり
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetTrmPortrait()
Call showStatus("書式設定中")
Call StopUpdating
ActiveWorkbook.Save
Call SetSheetFormat_HF(True) ' A4縦
Call Updating
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' テーマのフォント／横向き／書式あり
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetTrmLandScape()
Call showStatus("書式設定中")
Call StopUpdating
ActiveWorkbook.Save
Call SetSheetFormat_HF(False) ' A4横
Call Updating
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 方眼用紙たて
' テーマのフォント／縦向き／書式あり
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetTrmPortrait_GridStyle()
Call showStatus("方眼書式たて設定中")
Call StopUpdating
ActiveWorkbook.Save
Call SetSheetFormat_GridStyle(True) '方眼用紙たて
Call Updating
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 方眼用紙よこ
' テーマのフォント／横向き／書式あり
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetTrmLandscape_GridStyle()
Call showStatus("方眼書式よこ設定中")
Call StopUpdating
ActiveWorkbook.Save
Call SetSheetFormat_GridStyle(False) '方眼用紙よこ
Call Updating
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' Meiryo UI / 縦向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetMPortrait()
Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
Call SetSheetFormat("Meiryo UI", True, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' Yu Gothic / 縦向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetYuPortrait()
Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
Call SetSheetFormat("Yu Gothic", True, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' BIZ UDPゴシック / 縦向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetBIZPortrait()
Call SetHeaderFooter(ActiveSheet.PageSetup, "BIZ UDPゴシック")
Call SetSheetFormat("BIZ UDPゴシック", True, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' Meiryo UI / 横向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetMLandscape()
Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
Call SetSheetFormat("Meiryo UI", False, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' Yu Gothic / 横向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetYuLandscape()
Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
Call SetSheetFormat("Yu Gothic", False, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' BIZ UDPゴシック / 横向き / 書式あり（余白少なめ）
' 対象:アクティブシート
'+++*********************************************************+++
Sub SetBIZLandscape()
Call SetHeaderFooter(ActiveSheet.PageSetup, "BIZ UDPゴシック")
Call SetSheetFormat("BIZ UDPゴシック", False, True)
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 全シートのヘッダー・フッターを消去
'+++*********************************************************+++
Sub ClearAllHeaderFooter()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible Then
With ws.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End If
Next ws
MsgBox "完了♪"
End Sub
'+++*********************************************************+++
' 横幅を1シートに収めるコード
'+++*********************************************************+++
Sub FitColumnsToOnePage()
With ActiveSheet
'印刷範囲を設定（A列～AE列の全行）
With .PageSetup
.PrintArea = .Range("A1", .Cells(.Rows.Count, 29)).Address
.Orientation = xlLandscape '横向き印刷
.Zoom = False '拡大縮小率を無効にする
.FitToPagesWide = 1 '横方向に1ページに収める
.FitToPagesTall = False '縦方向は制限なし
End With
End With
End Sub
'***=========================================================***
' シート書式設定関数
' 印刷向けに列幅・フォント・余白を整える
' 引数: フォント名, 縦向き(True)/横向き(False), 余白少なめ(True)/多め(False)
' 使用例: Call SetSheetFormat("Meiryo UI", False, True)
' 備考: A4サイズに収まるよう設計。余白は詩的な選択肢。
'***=========================================================***
Function SetSheetFormat(fontName As String, isPortrait As Boolean, isCompact As Boolean)
Dim centerWidth As Double, sideWidth As Double
Select Case fontName
Case "Yu Gothic": centerWidth = IIf(isPortrait, 58, 72)
Case "Meiryo UI": centerWidth = IIf(isPortrait, 72, 88)
Case "BIZ UDPゴシック": centerWidth = IIf(isPortrait, 60, 78)
Case Else: centerWidth = 60
End Select
sideWidth = 1.25
If Not isCompact Then
centerWidth = centerWidth - 5
sideWidth = sideWidth + 1
End If
With ActiveSheet.PageSetup
.Orientation = IIf(isPortrait, xlPortrait, xlLandscape)
End With
With ActiveSheet.Cells
.Font.Name = fontName
.Font.Size = 10
.RowHeight = 18.75
End With
With ActiveSheet
.Columns(1).ColumnWidth = sideWidth
.Columns(2).ColumnWidth = centerWidth
.Columns(2).WrapText = True
.Columns(3).ColumnWidth = sideWidth
End With
End Function
''+++*********************************************************+++
'' ヘッダー・フッター設定関数
'' 指定フォントで、全体の印刷情報を整える
'' ヘッダー: 左=日付 / 中央=シート名 / 右=ページ番号
'' フッター: 中央=ファイル名 / 左=（部署名＋作成者）※未使用
'' 引数: PageSetupオブジェクト, フォント名
'' 使用例: Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
''+++*********************************************************+++
'Function SetHeaderFooter(ps As PageSetup, fontName As String)
' With ps
' .LeftHeader = "&"" " & fontName & ", 標準""&10&D"
' .CenterHeader = "&"" " & fontName & ", 太字""&12&A"
' .RightHeader = "&"" " & fontName & ", 標準""P. &P/&N"
'
' '.LeftFooter = "&"" " & fontName & ", 標準""&10" & DEPARTMENT_NAME & vbLf & AUTHOR_NAME
' .LeftFooter = ""
' .CenterFooter = "&"" " & fontName & ", 標準""&10&F"
' .RightFooter = ""
' End With
'End Function
'
'
''*****************************************************
'' 全シートに Yu Gothic のヘッダー・フッターを設定
'' 対象: 全シート（非表示は除外）
'' 書式設定なし（印刷情報のみ）
''*****************************************************
'Sub AllH_F_YuG()
' Dim i As Long
' If Bln_Err = False Then
' Application.PrintCommunication = False
' For i = 1 To ActiveWorkbook.Sheets.Count
' If Worksheets(i).Visible Then
' Call SetHeaderFooter(Worksheets(i).PageSetup, "Yu Gothic")
' End If
' Next i
' Application.PrintCommunication = True
' End If
'End Sub
'
''*****************************************************
'' アクティブシートに Yu Gothic のヘッダー・フッターを設定
'' 対象: 単シート
'' 書式設定なし（印刷情報のみ）
''*****************************************************
'Sub SoloH_F_YuG()
' If Bln_Err = False Then
' Application.PrintCommunication = False
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
' Application.PrintCommunication = True
' End If
'End Sub
'
''*****************************************************
'' 全シートに Meiryo UI のヘッダー・フッターを設定
'' 対象: 全シート（非表示は除外）
'' 書式設定なし（印刷情報のみ）
''*****************************************************
'Sub AllH_F_MeiUI()
' Dim i As Long
' If Bln_Err = False Then
' Application.PrintCommunication = False
' For i = 1 To ActiveWorkbook.Sheets.Count
' If Worksheets(i).Visible Then
' Call SetHeaderFooter(Worksheets(i).PageSetup, "Meiryo UI")
' End If
' Next i
' Application.PrintCommunication = True
' End If
'End Sub
'
''*****************************************************
'' アクティブシートに Meiryo UI のヘッダー・フッターを設定
'' 対象: 単シート
'' 書式設定なし（印刷情報のみ）
''*****************************************************
'Sub SoloH_F_MeiUI()
' If Bln_Err = False Then
' Application.PrintCommunication = False
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
' Application.PrintCommunication = True
' End If
'End Sub
'
''*****************************************************
'' Meiryo UI / 縦向き / 書式あり（余白少なめ）
'' 対象: アクティブシート
''*****************************************************
'Sub SetMPortraite()
' If Bln_Err = False Then
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
' Call SetSheetFormat("Meiryo UI", True, True)
' End If
'End Sub
'
''*****************************************************
'' Yu Gothic / 縦向き / 書式あり（余白少なめ）
'' 対象: アクティブシート
''*****************************************************
'Sub SetYuPortraite()
' If Bln_Err = False Then
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
' Call SetSheetFormat("Yu Gothic", True, True)
' End If
'End Sub
'
''*****************************************************
'' Meiryo UI / 横向き / 書式あり（余白少なめ）
'' 対象: アクティブシート
''*****************************************************
'Sub SetMLandScape()
' If Bln_Err = False Then
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Meiryo UI")
' Call SetSheetFormat("Meiryo UI", False, True)
' End If
'End Sub
'
''*****************************************************
'' Yu Gothic / 横向き / 書式あり（余白少なめ）
'' 対象: アクティブシート
''*****************************************************
'Sub SetYuLandScape()
' If Bln_Err = False Then
' Call SetHeaderFooter(ActiveSheet.PageSetup, "Yu Gothic")
' Call SetSheetFormat("Yu Gothic", False, True)
' End If
'End Sub
コメント