【VBA】埋め込みグラフを作成し、パーツの設定を行う

0

    <機能>

    (1)アクティブシートにテスト用の表を自動作成します

        過去5年間のパリーグ勝利数

        出典:日本野球機構 年度別成績

    (2)埋め込みグラフを作成します(表と同じシートに作成)

    (3)グラフのパーツを設定します

     

    <動作検証&開発環境>

    Microsoft Office 2016

     

    <使い方>

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

    VBAでグラフを作成する()を呼び出すと埋め込みグラフ作成処理を開始します

     

    <実行イメージ>

    テスト表を作成し、左50、トップ250位置よりグラフを出力します

    VBA,埋め込みグラフ,ChartObjects,Axes,ChartArea

     

     

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

    'VBAでグラフを自動作成する

    '(1)アクティブシートにテスト用の表を作成

    '(2)埋め込みグラフを作成(表と同じシートにグラフを作成)

    '(3)グラフのパーツを設定する

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

    Sub VBAでグラフを作成する()

        Dim gyo As Long

        Dim clm As Long

        

        '//(1)テストデータ「過去5年間のパリーグ勝利数」表を作成

        SetTestData

        

        '//データの入っている最終行、最終列を取得

        gyo = Cells(Rows.Count, 1).End(xlUp).Row

        clm = Cells(1, Columns.Count).End(xlToLeft).Column

        

        '//(2)埋め込みグラフを作成

        '// 左:50 トップ:250 幅:500 高さ:350

        Set co = ActiveSheet.ChartObjects.Add(50, 250, 500, 350)

        '// グラフの種類は「積み上げ縦棒」

        '// グラフの種類についてはOffice Dev Centerを参照

        co.Chart.ChartType = xlColumnStacked

        '// グラフのデータソースを指定

        co.Chart.SetSourceData Source:=Range(Cells(1, 1), Cells(gyo, clm))

        

        '//(3)グラフパーツの設定

        '// グラフのタイトルを表示

        co.Chart.HasTitle = True

        '// グラフのタイトルを設定

        co.Chart.ChartTitle.Font.Name = "メイリオ"

        co.Chart.ChartTitle.Text = "過去5年間のパリーグ勝利数"

        

        '// 軸ラベルの書式設定

        '// AxesのxlCategoryはX軸、xlValueはY軸

        co.Chart.Axes(xlCategory).TickLabels.Font.Name = "メイリオ"

        co.Chart.Axes(xlCategory).TickLabels.Font.Size = 9

        co.Chart.Axes(xlValue).TickLabels.Font.Name = "メイリオ"

        co.Chart.Axes(xlValue).TickLabels.Font.Size = 9

        '// 軸の表示方向を指定する

        '// 反時計回りの角度を指定(マイナスを指定すると時計回り)

        co.Chart.Axes(xlCategory).TickLabels.Orientation = 45

        co.Chart.Axes(xlValue).TickLabels.Orientation = 0

        

        '// 凡例を表示

        co.Chart.HasLegend = True

        '// 凡例の位置を指定(下に表示)

        co.Chart.Legend.Position = xlLegendPositionTop

        'xlLegendPositionBottom 下

        'xlLegendPositionCorner 右上

        'xlLegendPositionLeft 左

        'xlLegendPositionRight 右

        'xlLegendPositionTop 上

        

        '// 背景色に緑(204, 255, 204)をセット

        co.Chart.ChartArea.Interior.Color = RGB(204, 255, 204)

        '// 枠線(二点鎖線)をセット

        co.Chart.ChartArea.Border.LineStyle = xlDashDotDot

        'xlContinuous 実線 (細)

        'xlDash 破線

        'xlDashDot 一点鎖線

        'xlDashDotDot 二点鎖線

        'xlDot 点線

        'xlDouble 二重線

        'xlSlantDashDot 斜め斜線

        'xlLineStyleNone 無し

    End Sub

     

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

    'アクティブシートに「過去5年間のパリーグ勝利数」表を作成する

    '出典 日本野球機構 年度別成績

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

    Sub SetTestData()

        Dim ar As Variant

        ar = Array( _

        "チーム名,2011年,2012年,2013年,2014年,2015年", _

        "福岡ソフトバンクホークス,88,67,73,78,90", _

        "北海道日本ハムファイターズ,72,74,64,73,79", _

        "千葉ロッテマリーンズ,54,62,74,66,73", _

        "埼玉西武ライオンズ,68,72,74,63,69", _

        "オリックス・バファローズ,69,57,66,80,61", _

        "東北楽天ゴールデンイーグルス,66,67,82,64,57")

        

        ThisWorkbook.Activate

        Cells.Select

        Selection.Clear

        Selection.ColumnWidth = 15

        Selection.RowHeight = 30

        Selection.Font.Name = "MS ゴシック"

        Selection.Font.Size = 10

        '//折り返して全体を表示する

        Selection.WrapText = True

        Range("A1").Select

        

        '//全てのグラフを削除

        Dim objShape As Shape

        For Each objShape In ActiveSheet.Shapes

            objShape.Delete

        Next

        

        '//データをシートに展開

        Dim i As Integer, j As Integer

        Dim wkbuf As Variant

        

        For i = 0 To UBound(ar)

            wkbuf = Split(ar(i), ",")

            '不正なデータであれば次レコードへ

            If UBound(wkbuf) <> 5 Then GoTo nextrec

            'データを表示

            For j = 0 To UBound(wkbuf)

                Cells(i + 1, j + 1) = wkbuf(j)

            Next j

        

    nextrec:

        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