Excelでヒートマップ

　どうもヒートマップとかのキーワードでやってくる人が一定数いるようで、バッドエクスペリエンスしかないというのも良心がとがめるので、自作のヒートマップ作成マクロおいてみます。あくまでアレイの発現比を可視化するために組んだものなので、0を中心にした三色スケールのみです。
　最小・最大値で指定したmについて、-m ~ 0 ~ mで、値に対応した色の正方形シェイプが出力されます。選択範囲内の全てで評価が行われて、シェイプはグループ化されます。
　セルの背景色でなく、シェイプを出力するようにしたのはExcel2003以前でセルに指定できる色が少なかったためですが、パワーポイントなどに転用することを考えるとExcel2007でも有用です。

heatBlockは線形に色が変化しますが、heatBlockSqrtは(value/m)^2を評価して色を決定します。0付近の値が小さく見積もられるので、発現変動が小さいものなどの色が弱くなり、大きな発現変動が強調されます。

　見よう見まねで組んでいるので、ベストなアルゴリズムではないかも。その辺について気づいたことがあったら、気軽にコメください。

Sub heatmapBlock()
    
    Dim i As Integer
    Dim j As Integer
    Dim colN As Integer
    Dim rowN As Integer
    Dim aC As Integer
    Dim aR As Integer
    Dim m As Long
    Dim colR As Integer
    Dim colG As Integer
    Dim colB As Integer
    Dim color1() As Variant
    Dim color2() As Variant
    Dim color3() As Variant
    Dim colind As Integer
    Dim myShapes() As Variant
    
    rowN = Selection.Rows.Count
    colN = Selection.Columns.Count
    ReDim myShapes(1 To rowN * colN)

    m = Application.InputBox( _
        "最大・最小値を指定してください。", _
        "最大最小値の指定", _
        2)

    color1 = Application.InputBox( _
        Prompt:="最小時の色を指定してください", _
        Title:="色の指定1", _
        Default:="{0,255,0}", _
        Type:=64)
        
    color2 = Application.InputBox( _
        Prompt:="中央値の色を指定してください", _
        Title:="色の指定2", _
        Default:="{0,0,0}", _
        Type:=64)
    
    color3 = Application.InputBox( _
        Prompt:="最大時の色を指定してください", _
        Title:="色の指定3", _
        Default:="{255,0,102}", _
        Type:=64)
    
    aR = Selection.Rows(1).Row
    aC = Selection.Columns(1).Column
     
    For i = 1 To rowN
        For j = 1 To colN
            Cells(aR + i - 1, aC + j - 1).Activate
            myVal = ActiveCell
            
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, j * 20, i * 20, 20, 20).Select
            
                If myVal <= -m Then
                    colR = color1(1)
                    colG = color1(2)
                    colB = color1(3)
                ElseIf -m < myVal And myVal < 0 Then
                    colind = -myVal / m * 128
                    colR = color2(1) + WorksheetFunction.Round((color1(1) - color2(1)) * colind / 128, 0)
                    colG = color2(2) + WorksheetFunction.Round((color1(2) - color2(2)) * colind / 128, 0)
                    colB = color2(3) + WorksheetFunction.Round((color1(3) - color2(3)) * colind / 128, 0)
                ElseIf myVal = 0 Then
                    colR = color2(1)
                    colG = color2(2)
                    colB = color2(3)
                ElseIf 0 < myVal And myVal < m Then
                    colind = myVal / m * 128
                    colR = color2(1) + WorksheetFunction.Round((color3(1) - color2(1)) * colind / 128, 0)
                    colG = color2(2) + WorksheetFunction.Round((color3(2) - color2(2)) * colind / 128, 0)
                    colB = color2(3) + WorksheetFunction.Round((color3(3) - color2(3)) * colind / 128, 0)
                ElseIf myVal >= m Then
                    colR = color3(1)
                    colG = color3(2)
                    colB = color3(3)
                End If
            
            With Selection.ShapeRange
                .Line.Visible = msoTrue
                .Fill.Visible = msoTrue
                .Fill.ForeColor.RGB = RGB(colR, colG, colB)
                .Fill.Solid
            End With
            myShapes(colN * (i - 1) + j) = Selection.Name
        Next j
    Next i
    
    ActiveSheet.Shapes.Range(myShapes).Group
    Erase myShapes

End Sub

Sub heatmapBlockSqrt()
        
    Dim i As Integer
    Dim j As Integer
    Dim colN As Integer
    Dim rowN As Integer
    Dim aC As Integer
    Dim aR As Integer
    Dim m As Long
    Dim colR As Integer
    Dim colG As Integer
    Dim colB As Integer
    Dim color1() As Variant
    Dim color2() As Variant
    Dim color3() As Variant
    Dim colind As Integer
    Dim myShapes() As Variant
    
    rowN = Selection.Rows.Count
    colN = Selection.Columns.Count
    ReDim myShapes(1 To rowN * colN)

    m = Application.InputBox( _
        "最大・最小値を指定してください。", _
        "最大最小値の指定", _
        2)

    color1 = Application.InputBox( _
        Prompt:="最小時の色を指定してください", _
        Title:="色の指定1", _
        Default:="{0,255,0}", _
        Type:=64)
        
    color2 = Application.InputBox( _
        Prompt:="中央値の色を指定してください", _
        Title:="色の指定2", _
        Default:="{0,0,0}", _
        Type:=64)
    
    color3 = Application.InputBox( _
        Prompt:="最大時の色を指定してください", _
        Title:="色の指定3", _
        Default:="{255,0,102}", _
        Type:=64)
    
    aR = Selection.Rows(1).Row
    aC = Selection.Columns(1).Column
     
    For i = 1 To rowN
        For j = 1 To colN
            Cells(aR + i - 1, aC + j - 1).Activate
            myVal = ActiveCell
            
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, j * 20, i * 20, 20, 20).Select
            
                If myVal <= -m Then
                    colR = color1(1)
                    colG = color1(2)
                    colB = color1(3)
                ElseIf -m < myVal And myVal < 0 Then
                    colind = (myVal / m)^2 * 128
                    colR = color2(1) + WorksheetFunction.Round((color1(1) - color2(1)) * colind / 128, 0)
                    colG = color2(2) + WorksheetFunction.Round((color1(2) - color2(2)) * colind / 128, 0)
                    colB = color2(3) + WorksheetFunction.Round((color1(3) - color2(3)) * colind / 128, 0)
                ElseIf myVal = 0 Then
                    colR = color2(1)
                    colG = color2(2)
                    colB = color2(3)
                ElseIf 0 < myVal And myVal < m Then
                    colind = (myVal / m)^2 * 128
                    colR = color2(1) + WorksheetFunction.Round((color3(1) - color2(1)) * colind / 128, 0)
                    colG = color2(2) + WorksheetFunction.Round((color3(2) - color2(2)) * colind / 128, 0)
                    colB = color2(3) + WorksheetFunction.Round((color3(3) - color2(3)) * colind / 128, 0)
                ElseIf myVal >= m Then
                    colR = color3(1)
                    colG = color3(2)
                    colB = color3(3)
                End If
            
            With Selection.ShapeRange
                .Line.Visible = msoTrue
                .Fill.Visible = msoTrue
                .Fill.ForeColor.RGB = RGB(colR, colG, colB)
                .Fill.Solid
            End With
            myShapes(colN * (i - 1) + j) = Selection.Name
        Next j
    Next i
    
    ActiveSheet.Shapes.Range(myShapes).Group
    Erase myShapes

End Sub