【VBA】表の体裁を整え、印刷範囲/ヘッダー/フッターを設定する

0

    <機能>

    VBAで表の体裁を整え、即印刷できるようにシートを設定します

    (1)シートを挿入しテストデータ「鮮魚の一人当たり購入数量」をセット
    (2)セル幅、セル内の表示位置、罫線等をセット
    (3)印刷範囲、ヘッダー、フッターをセット

     

    <動作検証&開発環境>
    Microsoft Office 2016

     

    <実行イメージ>

    元のテキストのみ状態

    表,体裁,ColumnWidth,フォントサイズ,フォント,中央揃え

    セル幅、セル内の表示位置、罫線等をセット

    VBA,PageSetup,LineStyle,FitToPagesWide,印刷設定,横向き

    即印刷できるように印刷範囲、ヘッダー、フッターも設定済み

    CenterHeader,CenterFooter,Margin,水平方向,ズーム

     

    <使い方>

    適当なところにソースを貼り付けてください

    表の体裁を自動で設定する() を実行すると処理を開始します

     

    '********************************************

    '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

     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     



    selected entries

    categories

    calendar

    S M T W T F S
         12
    3456789
    10111213141516
    17181920212223
    24252627282930
    31      
    << March 2024 >>

    profile

    others

    archives