VBA Vol.1 (グラフを塗り分けるマクロ)

ExcelのVBAでグラフの色をきれいに描こうと試みた。

なぜならデフォルトのExcelのグラフの色はイケてないからだ。
あとはたくさんのデータ系列があるときにはいちいち1つずつ書式設定なんてやってられないから。

どうせなら最近流行りの色鮮やかな感じにしようと思い、
赤 橙 黄 緑 青 藍 紫って感じに波長の長い順に並べるアルゴリズムにしようと考えた。
名付けてRainbowGraph。虹色のグラフ。

Red, Green, Blueの値の混ぜ具合で出力の色が変わるRGBっていう関数を使った。
RGB(red, green, blue)っていう風に3色の濃さを引数にしてる。
引数はそれぞれ0 - 255の整数。

赤から順に虹色に変化させるには、下の表の順番でRGBの引数を変えていかなきゃいけない。

Red	Green	Blue	Result
255	0	0	Red
255	255	0	Yellow
0	255	0	Green
0	255	255	Cyan
0	0	255	Blue
255	0	255	Magenta
255	0	0	Red

ちなみにRGB(0,0,0)なら黒、RGB(255,255,255)なら白。光の3原色と一緒。

そしてできた。アルゴリズム(といえるほど高級なものでもない)は以下の通り。

まず、赤から紫までいって赤に戻るまでのRGBの整数の組み合わせは256 * 6 = 1536通りある。6の由来は、表の行数 - 1個分。最初は赤って決めてるから7 - 1 = 6てこと。

そこで1536 / (データ系列の数)ずつインクリメントしてって、その結果を256で割った商を6通りに場合分けし、RGBのどの引数を増やす/減らすか選ぶ。そして256で割った時の剰余をRGBの引数のどれかに足して/引いてからそれぞれのデータ系列の色に指定するっていう寸法。

これはお気に入りになった。
ちなみに最初の図形はGaussian波形で、ピークを細かく増やしていったGaussianを計200本描いてこれにマクロを適用したもの。

デフォルトと比べてみると、その違いは歴然。
下の図の1つ目がデフォルトで作成しっぱなしの方で、2つ目がマクロ使ったあと。

自分のサーバーがないために、保存用も兼ねて下に無理やりソースコードを入れた。
誰か使ってくれないかな。自己責任で。グラフきれいになるし！

ちなみにExcelでグラフを作成してそれが表示されてる状態じゃないと使えません。散布図でね。
実行するとなんか聞かれるけど、「はい」って言っとけば起動する。たぶん。

あと、残念ながらExcel2003だと載せた図ほど色のグラデーションがきれいじゃなくなる。

'虹色にグラフを色分けするマクロ
Sub RainbowGraph()
    
    Application.ScreenUpdating = False
    
    If ActiveChart Is Nothing Then
        MsgBox "Please activate a graph sheet !"
        Exit Sub
    End If
    
    Dim Line As Integer         'マーカー表示を線にするかどうか
    Dim SampleNum As Integer    'グラフの数
    Dim i As Integer            'for用変数
    
    'RGBの値を入れる変数
    Dim Red As Integer
    Dim Green As Integer
    Dim Blue As Integer
    
    Dim TotalColor As Integer   '虹色のトータルの選べる数
    TotalColor = 256 * 6
    
    Line = MsgBox("Do you want to make Graph drawn with Line ?", vbYesNoCancel, "To change from Marker to Line or not")
    If Line = vbCancel Then
        MsgBox "Exit Sub"
        Exit Sub
    End If
    
    SampleNum = ActiveChart.SeriesCollection.Count
        
    If Line = vbYes Then
        For i = 0 To SampleNum - 1
            ActiveChart.SeriesCollection(i + 1).MarkerStyle = xlNone
        Next i
    End If
    
    'RGBの組み合わせは256*6=1536ある。初期値は赤。
    Red = 255
    Green = 0
    Blue = 0
    
    '※Mod はLong型にキャストされる。a Mod b のとき、aもbも「銀行型丸め」が行われた結果が返される。
    
    For i = 0 To SampleNum - 1
        Select Case ((TotalColor / SampleNum) * i) \ 256
            Case 0  '緑を増やす
                Red = 255
                Green = 0 + CInt((((TotalColor / SampleNum) * i) Mod 256))
                Blue = 0
            Case 1  '赤を減らす
                Red = 255 - CInt((((TotalColor / SampleNum) * i) Mod 256))
                Green = 255
                Blue = 0
            Case 2  '青を増やす
                Red = 0
                Green = 255
                Blue = 0 + CInt((((TotalColor / SampleNum) * i) Mod 256))
            Case 3  '緑を減らす
                Red = 0
                Green = 255 - CInt((((TotalColor / SampleNum) * i) Mod 256))
                Blue = 255
            Case 4  '赤を増やす
                Red = 0 + CInt((((TotalColor / SampleNum) * i) Mod 256))
                Green = 0
                Blue = 255
            Case 5  '青を減らす
                Red = 255
                Green = 0
                Blue = 255 - CInt((((TotalColor / SampleNum) * i) Mod 256))
        End Select
        
        If Line = vbYes Then
            ActiveChart.SeriesCollection(i + 1).Border.Color = RGB(Red, Green, Blue)
                        
            '線の太さは xlHairline < xlThin < xlMedium < xlThick 100個より大きいと細くする。
            If SampleNum > 300 Then
                ActiveChart.SeriesCollection(i + 1).Border.Weight = xlHairline
            Else
                ActiveChart.SeriesCollection(i + 1).Border.Weight = xlThick
            End If
            ActiveChart.SeriesCollection(i + 1).Border.LineStyle = xlContinuous
        ElseIf Line = vbNo Then
            ActiveChart.SeriesCollection(i + 1).MarkerBackgroundColor = RGB(Red, Green, Blue)
            ActiveChart.SeriesCollection(i + 1).MarkerForegroundColor = RGB(Red, Green, Blue)
            ActiveChart.SeriesCollection(i + 1).MarkerSize = myMarkerSize
            ActiveChart.SeriesCollection(i + 1).Border.LineStyle = xlNone
        End If
        
    Next i
    
    Application.ScreenUpdating = True
    
End Sub