グラフの操作

【ExcelVBA】散布図のプロットエリアの4つの領域（第一象限から第四象限）ごとにプロットの色を変更するFunctionモジュール

果たして需要はあるのか？

私の職場で、ちらっとだけ、「散布図のプロットエリアの4つの領域ごとに色を変えたい」といったご要望があったので、散布図のデータラベルの重なりをずらす・防ぐFunctionモジュールを作成するついでに作成したモジュールです。

1.使用例① プロットの色を変える

1.サンプル

下図のような散布図があったとします。
scatter_collor_before

2.Functionモジュールの実行例

最もシンプルな実行例は、以下のように、チャート名と各エリアのカラーをRGBで指定して実行します。
引数のbookとsheetは省略しているので、前提として、対象ブックと対象シートがアクティブになっている必要があります。

Sub main()

    FC_ArrangeScatterColor chartName:="グラフ 1", area1:=RGB(255, 0, 0), area2:=RGB(0, 255, 0), _
                           area3:=RGB(0, 0, 255), area4:=RGB(255, 153, 0)
    
End Sub

3.実行結果

以下のように、各エリアのプロットが、指定したRGBカラーに変わっています。
scatter_collor_after

 

2.使用例② プロットとデータラベルの色を変える

1.サンプル

使用例①のサンプルと同じものを使用します。

2.Functionモジュールの実行例

使用例①に対して、更に、データラベルのカラーもプロットに合わせるため「label:=True」を追加しています。

Sub main()

    FC_ArrangeScatterColor chartName:="グラフ 1", area1:=RGB(255, 0, 0), area2:=RGB(0, 255, 0), _
                           area3:=RGB(0, 0, 255), area4:=RGB(255, 153, 0), label:=True, _
                           book:="散布図.xlsm", sheet:="散布図"
    
End Sub

3.実行結果

以下のように、データラベルもプロットと同じ色に変わっています。
scatter_collor_after_label

 

3.コード

以下はFunctionモジュールのプログラムになります。
右上のコピーボタンを押せば、プログラム全体をコピーできます。

Function FC_ArrangeScatterColor(chartName As String, Optional area1 As Variant, Optional area2 As Variant, _
                                Optional area3 As Variant, Optional area4 As Variant, _
                                Optional label As Boolean = False, Optional book As String, Optional sheet As String)
'散布図のプロットエリアの4つの領域（第一象限から第四象限）ごとにプロットの色を変更する
'chartName  :グラフ名を指定する。省略不可。
'area1      :第一象限（右上）の色をRGBで指定する。省略した場合は色を変更しない。
'area2      :第二象限（左上）の色をRGBで指定する。省略した場合は色を変更しない。
'area3      :第二象限（左下）の色をRGBで指定する。省略した場合は色を変更しない。
'area4      :第二象限（右下）の色をRGBで指定する。省略した場合は色を変更しない。
'label       :ラベルの色もプロットと同じ色に変更する場合はTrueを指定する。既定値=False。
'book       :ワークブック名を指定する。省略した場合はアクティブブックを対象とする。
'sheet      :シート名を指定する。省略した場合はアクティブシートを対象とする。

    Dim wb As Workbook
    Dim ws As Worksheet

    Dim myChart As ChartObject
    Dim myGraph As chart        'ChartObjectオブジェクト(箱)の内側のChartオブジェクト(グラフ)
    Dim myAxes As Axes          '軸オブジェクト
    
    Dim n_keiretsu As Long      '系列数
    Dim n_yoso() As Variant     '系列内の要素数
    
    Dim xCenter As Double       'x軸の中心線の値
    Dim yCenter As Double       'y軸の中心線の値
    
    Dim dl As DataLabel         'データラベルオブジェクト
    Dim dataValue() As Variant  '各プロットのx値、y値
    
    Dim userColor() As Variant  'ユーザー定義フォーマットカラー

    Dim i&, j&, k&              'インデックス変数
    
    '対象ブックをセット
    If book <> "" Then
        Set wb = Workbooks(book)
    Else
        Set wb = ActiveWorkbook
    End If
    
    '対象シートをセット
    If sheet <> "" Then
        Set ws = wb.Worksheets(sheet)
    Else
        Set ws = wb.ActiveSheet
    End If
    
    'Chartオブジェクトをセット
    Set myChart = ws.ChartObjects(chartName)
    Set myGraph = myChart.chart
    Set myAxes = myGraph.Axes
    
    'x軸とy軸の中心値を取得
    xCenter = myAxes.Item(xlCategory).CrossesAt
    yCenter = myAxes.Item(xlValue).CrossesAt

    'グラフを非アクティブ化
    myGraph.Deselect
    
    '系列数の取得
    n_keiretsu = myGraph.SeriesCollection.Count
    
    '系列内の要素数の取得
    ReDim n_yoso(1 To n_keiretsu)
    For i = 1 To n_keiretsu
        n_yoso(i) = myGraph.SeriesCollection(i).Points.Count
    Next i
    
    '動的配列を定義
    ReDim dataValue(1 To n_keiretsu, 1 To Application.WorksheetFunction.Max(n_yoso))

    'ユーザー定義フォーマットで選択できるカラーを格納
    userColor = Array("[黒]", "[青]", "[水]", "[緑]", "[紫]", "[赤]", "[白]", "[黄]")
    
    'カラーの変更
    For i = 1 To n_keiretsu
        For j = 1 To n_yoso(i)

            '各プロットのデータラベルをセット
            Set dl = myGraph.SeriesCollection(i).Points(j).DataLabel
            
            'データ値(x値(0),y値(1))を配列に格納
            dataValue(i, j) = Array(myGraph.SeriesCollection(i).XValues, myGraph.SeriesCollection(i).Values)
            dataValue(i, j) = Array(dataValue(i, j)(0)(j), dataValue(i, j)(1)(j))
            
            
            'ユーザー定義フォーマットからカラーを消す
            If label = True Then
                For k = LBound(userColor) To UBound(userColor)
                    dl.NumberFormatLocal = Replace(dl.NumberFormatLocal, userColor(k), "")
                Next k
            End If
           
            If dataValue(i, j)(0) >= xCenter And dataValue(i, j)(1) >= yCenter Then      '第一象限
                If IsMissing(area1) = False Then
                    myGraph.SeriesCollection(i).Points(j).MarkerBackgroundColor = area1
                    If label = True Then dl.Font.Color = area1
                End If
            ElseIf dataValue(i, j)(0) < xCenter And dataValue(i, j)(1) >= yCenter Then   '第二象限
                If IsMissing(area2) = False Then
                    myGraph.SeriesCollection(i).Points(j).MarkerBackgroundColor = area2
                    If label = True Then dl.Font.Color = area2
                End If
            ElseIf dataValue(i, j)(0) < xCenter And dataValue(i, j)(1) < yCenter Then    '第三象限
                If IsMissing(area3) = False Then
                    myGraph.SeriesCollection(i).Points(j).MarkerBackgroundColor = area3
                    If label = True Then dl.Font.Color = area3
                End If
            ElseIf dataValue(i, j)(0) >= xCenter And dataValue(i, j)(1) < yCenter Then   '第四象限
                If IsMissing(area4) = False Then
                    myGraph.SeriesCollection(i).Points(j).MarkerBackgroundColor = area4
                    If label = True Then dl.Font.Color = area4
                End If
            End If
           
        Next j
    Next i
    
    'A1セルをアクティブにして終了
    Application.Goto Reference:=ws.Range("A1"), Scroll:=True

End Function

-グラフの操作
-,