【VBA】表の体裁を整え、印刷範囲/ヘッダー/フッターを設定する
<機能>
VBAで表の体裁を整え、即印刷できるようにシートを設定します
(1)シートを挿入しテストデータ「鮮魚の一人当たり購入数量」をセット
(2)セル幅、セル内の表示位置、罫線等をセット
(3)印刷範囲、ヘッダー、フッターをセット
<動作検証&開発環境>
Microsoft Office 2016
<実行イメージ>
元のテキストのみ状態
セル幅、セル内の表示位置、罫線等をセット
即印刷できるように印刷範囲、ヘッダー、フッターも設定済み
<使い方>
適当なところにソースを貼り付けてください
表の体裁を自動で設定する() を実行すると処理を開始します
'********************************************
'VBAで表の体裁を自動で整える
'(1)シートを挿入しテストデータ「鮮魚の一人当たり購入数量」をセット
'(2)セル幅、罫線をセット
'(3)印刷範囲、ヘッダー、フッターをセット
'********************************************
Sub 表の体裁を自動で設定する()
Dim strwk As String
Dim lgyo As Long, lclm As Long
'新規シートを先頭に挿入
ThisWorkbook.Activate
strwk = Now
ThisWorkbook.Worksheets.Add before:=Worksheets(1)
Sheets(1).Name = "表の体裁を設定_" & Format(strwk, "yyyymmddhhmmss")
Sheets(1).Activate
'//(1)アクティブシートにテストデータをセット
SetTestData
'データの入っている最終行、最終列を取得
lgyo = Cells(Rows.Count, 1).End(xlUp).Row
lclm = Cells(5, 1).End(xlToRight).Column
'//(2)セル幅、罫線をセット
Range(Cells(1, 1), Cells(lgyo, lclm)).Select
Selection.ColumnWidth = 10
Selection.RowHeight = 20
Selection.Font.Name = "メイリオ"
Selection.Font.Size = 11
'折り返して全体を表示
Selection.WrapText = True
'水平方向、垂直方向中央揃え
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
'A列の2行目と9行目の設定
With Range("A2", "A9")
'「折り返して全体を表示」設定なし
.WrapText = False
'「縮小して全体を表示」も念のため未設定にしておく
.ShrinkToFit = False
'水平方向左揃えを設定
.HorizontalAlignment = xlLeft
End With
'表全体に罫線を設定(実線、極細)
With Range("A4:N7")
'Bordersの引数は省略
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
'項目行に背景色とセルの下に2本線を設定
With Range("A4:N4")
.Borders(xlEdgeBottom).LineStyle = xlDouble
.Interior.Color = RGB(169, 208, 142)
End With
'//(3)印刷範囲、ヘッダー、フッターをセット
'//PageSetupメンバーの詳細については Office DevCenter を参照
With ActiveSheet.PageSetup
'印刷時の拡大率(今回は横1ページ×縦未指定 とするため指定なし)
.Zoom = False
'横1ページ×縦未指定
.FitToPagesWide = 1
.FitToPagesTall = False
'印刷の向き(横:xlLandscape 縦:xlPortrait)
.Orientation = xlLandscape
'ヘッダーを設定
'詳細は ヘッダーとフッターに指定できる書式コード 参照
'タイトル(ゴシック・太字・24pt・下線付き)
.CenterHeader = "&""MS Pゴシック,太字""&24&U水産物の消費動向"
'日付と現在時刻
.RightHeader = "印刷日時:&D(&T)"
'フッターを設定
'ページ番号
.CenterFooter = "&P/&N"
'ブック名とシート名
.RightFooter = "&F(&A)"
'余白設定
'上3、左1.5、右1.5、下2、ヘッダー2、フッター1
.TopMargin = Application.CentimetersToPoints(3)
.LeftMargin = Application.CentimetersToPoints(1.5)
.RightMargin = Application.CentimetersToPoints(1.5)
.BottomMargin = Application.CentimetersToPoints(2)
.HeaderMargin = Application.CentimetersToPoints(2)
.FooterMargin = Application.CentimetersToPoints(1)
'水平方向ページ中央
.CenterHorizontally = True
End With
'改ページプレビュー表示
ActiveWindow.View = xlPageBreakPreview
'ズーム85%で表示
ActiveWindow.Zoom = 85
'設定終了メッセージ
Range("A1").Select
MsgBox "設定がおわりました", vbInformation
End Sub
'********************************************
'シートに「鮮魚の1人当たり購入数量ぼ品目別割合」表を作成する
'出典 水産庁「水産物の消費動向」
'********************************************
Sub SetTestData()
Dim ar As Variant, wkbuf As Variant
Dim i As Integer
ar = Array(",,,,,,,,,,,,,", _
"図2-1-4 鮮魚の1人当たり購入数量の品目別割合,,,,,,,,,,,,,", _
",,,,,,,,,,,,,単位:Kg", _
",マグロ,アジ,イワシ,カツオ,カレイ,サケ,サバ,サンマ,タイ,ブリ,イカ,タコ,その他", _
"昭和40年,0.57,1.92,0.38,0.19,0.77,0.44,1.59,0.44,0.39,0.34,1.78,0.36,5.29", _
"昭和57年,0.83,0.69,0.68,0.37,0.76,0.27,0.52,0.42,0.27,0.58,1.62,0.38,5.06", _
"平成22年,0.8,0.45,0.26,0.36,0.4,0.95,0.41,0.54,0.23,0.67,0.82,0.27,3.6", _
",,,,,,,,,,,,,", _
"資料:総務省「家計調査」(昭和40年、昭和57年は全世帯(農林漁家世帯を除く)、平成22年は二人以上の世帯(農林漁家世帯を除く))に基づき水産庁で作成,,,,,,,,,,,,,")
For i = 0 To UBound(ar)
wkbuf = Split(ar(i), ",")
'データを表示
For j = 0 To UBound(wkbuf)
Cells(i + 1, j + 1) = wkbuf(j)
Next j
Next i
End Sub
よろしければポチッと押してください