BDAstyle

ビジネスデータ分析ツールの作成 with Excel

散布図行列の作成 with Excel VBA

1.イントロダクション

散布図行列作成のためのマクロの作例です。左下半分に散布図・右上半分に相関係数を表示する形式のものです。また右上について,デフォルトの状態ではフォントサイズを相関係数|0.3|程度を目安に固定式から比例式に切り替える仕様をとっています。

「R」ではpairs()関数などにより簡単に作成できる散布図行列も,Excelでは 筆者の知る限りなかなかの困難を伴うようです。アドインの「分析ツール」―「相関」機能には散布図行列を作成するオプションが現状では用意されていないので,これをマクロでなんとかするのがこのページの主旨ですが,ひょっとするとこれはバッドノウハウの範疇にかかる内容のような気がしないでもありません。

とまれ以下,Excelで散布図行列を作るにあたって必要とされる多大な手間の軽減を目的としたマクロの導入と実行に関する手続きです。


2.工程

Step 0シチュエーションの設定

企業情報サービス会社Xがあります。Xは同社の提供するオンライン情報サービスについて,ある期間におけるデータの参照数を会員ID別・記事項目別にまとめました(下表)。

初期データ

この表は,左端1列が項目列その他の列が変数列(ここでは9個)となっています。このマクロは,指定したひと続きの変数列の組み合わせにおいて散布図を作成します。したがって選択範囲に空白列を挟む場合には正常に機能しません。

免責および特記事項

1. コードの導入

Step 1VBE(Visual Basic Editor)の起動(1)

開発タブ「コード」グループのVisual Basicボタンをクリックします。

Step 2VBE(Visual Basic Editor)の起動(2)

VBEが起動しました。

Step 3VBEの操作・VBAコードの導入(1)

VBE挿入メニュー標準モジュールをクリックします。

Step 4VBEの操作・VBAコードの導入(2) 「標準モジュール」ウインドウ

「標準モジュール」ウインドウが表示されました。

Step 5VBEの操作・VBAコードの導入(3) コードのコピー

次のコードをすべて選択し,コピーします。

Const Ratio As Double = 0.1 ' レンジに加えるマージンの量(初期値:10%)

Sub SCATTERMATRIX1_draw()

' *** 散布図行列の作成 ver.2.0.0
' ***「散布図行列の作成 with Excel VBA」で掲載する形式の散布図行列を作成するマクロです。
' *** 詳細は当該ページ(http://bdastyle.net/tools/correlation-coefficient/page5-scattermatrix.html)をご覧ください。
' *** BDAstyle-ビジネスデータ分析ツールの作成 with Excel (http://bdastyle.net/)
' *** by hawcas 2014, 2016

On Error GoTo myError

Application.ScreenUpdating = False

Const axLeft As Long = 100 ' 描画開始位置(pt, 左)
Const axTop As Long = 100 ' 描画開始位置(pt, 上)
Const paWidth As Long = 100 ' セルサイズ(pt, 幅)
Const paHeight As Long = 100 ' セルサイズ(pt, 高さ)
Const adjY As Long = 64 ' Y方向のラベルの突き出し(-:増える +:減る)
Const adjX As Long = 36 ' X方向のラベルの突き出し(+:増える -:減る)

Dim v As Long ' 変数の数
Dim n As Long ' サイズ
Dim header() As String ' 見出し格納用の配列
Dim r() ' 相関係数格納用の配列
Dim param1 As String ' 変数1のデータ範囲
Dim param2 As String ' 変数2のデータ範囲

Dim xMin As Double ' x軸のMin
Dim xMax As Double ' x軸のMax
Dim yMin As Double ' y軸のMin
Dim yMax As Double ' y軸のMax
Dim xMgn As Double ' x軸のマージン
Dim yMgn As Double ' y軸のマージン

Dim head As Shape ' 「見出し」オブジェクト
Dim cor As Shape ' 「相関係数」オブジェクト

Dim x As Long   ' 以下カウンタ
Dim y As Long

' 変数の数の取得
v = ActiveWindow.RangeSelection.Columns.Count
' データサイズの取得
n = ActiveWindow.RangeSelection.Rows.Count - 1

If v < 2 Or n < 4 Then ' [エラー処理1] 選択範囲が適切か簡易チェック
    MsgBox "選択範囲が正しくない可能性があります"
    Exit Sub
End If

' 変数名・相関係数用配列の再定義
ReDim header(v)
ReDim r(v, v)

' 変数名を配列に格納
For x = 1 To v
    header(x) = ActiveSheet.Range(ActiveWindow.RangeSelection.Address).Cells(1, x).Value
    If IsNumeric(header(x)) = True Or header(x) = "" Then ' [エラー処理2] 見出しが数値型 or "" を弾く
        MsgBox "数値型、もしくは空の変数名は利用できません"
        Exit Sub
    End If
Next
    Dim vlu ' [エラー処理3]データが数値型かを確認
    For Each vlu In ActiveWindow.RangeSelection.Range("a2").Resize(RowSize:=n, ColumnSize:=v)
        If IsNumeric(vlu) = False Then
            MsgBox "見出しを除く範囲に、文字型のデータを利用することはできません"
            Exit Sub
        End If
    Next

' ブックを複写
ActiveSheet.Copy

' マトリクスを描画
For x = 1 To v ' [ループA]列方向の処理
        param1 = ActiveWindow.RangeSelection.Cells(2, x).Address & ":" & _
            ActiveWindow.RangeSelection.Cells(2 + n - 1, x).Address ' 変数1のアドレス(文字列)を作成し
        xMin = Application.WorksheetFunction.Min(Range(param1)) ' 項目軸のMinと
        xMax = Application.WorksheetFunction.Max(Range(param1)) ' Maxを求める
        
    For y = 1 To v ' [ループB]行方向の処理
        param2 = ActiveWindow.RangeSelection.Cells(2, y).Address & ":" & _
            ActiveWindow.RangeSelection.Cells(2 + n - 1, y).Address ' 変数2のアドレス(文字列)を作成する

        ' 描画するオブジェクトをx,yの内容によって分岐させる
        Select Case x
            Case Is < y ' 散布図行列(マトリクスの左下部を描く)
                    r(x, y) = Application.WorksheetFunction.Pearson(Range(param1), Range(param2)) ' 相関係数を計算し
                    yMin = Application.WorksheetFunction.Min(Range(param2)) ' 数値軸のMinと
                    yMax = Application.WorksheetFunction.Max(Range(param2)) ' Maxも求めておく
                    
                    If x = 1 Then ' y方向のラベル(グラフオブジェクト)を作る
                        ActiveSheet.Shapes.AddChart(xlXYScatter, axLeft + adjY, axTop + y * paHeight, _
                            paWidth, paHeight).Select ' 引数:Left top width height
                        ActiveChart.SetSourceData Source:=Range(param1 & "," & param2) ' データ範囲の指定
                            yMgn = Margin(yMin, yMax) ' y軸マージン量の決定
                            xMgn = Margin(xMin, xMax) ' x軸マージン量の決定
                 
                        With ActiveChart ' 書式設定
                            .HasLegend = False
                            .SeriesCollection(1).MarkerStyle = xlMarkerStyleNone ' -4142
                            .Axes(xlValue).HasMajorGridlines = False
                            
                            Call Y_AXIS(yMin, yMax, yMgn)
                            .Axes(xlValue).TickLabelPosition = xlLow
                            .Axes(xlValue).Format.Line.Visible = msoFalse
                            
                            Call X_AXIS(xMin, xMax, xMgn)
                            .Axes(xlCategory).TickLabelPosition = xlNone
                            .Axes(xlCategory).Format.Line.Visible = msoFalse
                            
                            .SetElement (msoElementPrimaryValueGridLinesMajor) ' 主軸目盛り線の挿入
                        End With
                    End If
                    
                    If y = v Then ' x方向のラベル(グラフオブジェクト)を作る
                        ActiveSheet.Shapes.AddChart(xlXYScatter, axLeft + x * paWidth, axTop + y * paHeight + adjX, _
                            paWidth, paHeight).Select ' 引数:Left top width height
                        ActiveChart.SetSourceData Source:=Range(param1 & "," & param2) ' データ範囲の指定
                            yMgn = Margin(yMin, yMax) ' y軸マージン量の決定
                            xMgn = Margin(xMin, xMax) ' x軸マージン量の決定
                        
                        With ActiveChart
                            .HasLegend = False
                            .SeriesCollection(1).MarkerStyle = xlMarkerStyleNone ' -4142
                            .Axes(xlValue).HasMajorGridlines = False
                            
                            Call Y_AXIS(yMin, yMax, yMgn)
                            .Axes(xlValue).TickLabelPosition = xlNone
                            .Axes(xlValue).Format.Line.Visible = msoFalse
                            
                            Call X_AXIS(xMin, xMax, xMgn)
                            .Axes(xlCategory).TickLabelPosition = xlLow
                            .Axes(xlCategory).Format.Line.Visible = msoFalse
                            
                            .Axes(xlCategory).TickLabels.Orientation = xlUpward ' ラベルを-90°回転
                            .SetElement (msoElementPrimaryCategoryGridLinesMajor) ' 主軸目盛り線の挿入
                        End With
                    End If
                    
                    ' 散布図の作成
                    ActiveSheet.Shapes.AddChart(xlXYScatter, axLeft + x * paWidth, axTop + y * paHeight, _
                        paWidth, paHeight).Select
                    ActiveChart.SetSourceData Source:=Range(param1 & "," & param2) ' データ範囲の指定
                        yMgn = Margin(yMin, yMax) ' y軸マージン量の決定
                        xMgn = Margin(xMin, xMax) ' x軸マージン量の決定
                    With ActiveChart
                        .HasLegend = False
                        .Axes(xlValue).HasMajorGridlines = False
                        
                        Call Y_AXIS(yMin, yMax, yMgn)
                        .Axes(xlValue).TickLabelPosition = xlNone
                        .Axes(xlValue).Delete ' 0線を削除(元データに正負の値が混在するとき 軸の描画が邪魔な場合の対処)
                        
                        Call X_AXIS(xMin, xMax, xMgn)
                        .Axes(xlCategory).TickLabelPosition = xlNone
                        .Axes(xlCategory).Delete ' 0線を削除(元データに正負の値が混在するとき 軸の描画が邪魔な場合の対処)
                    End With
                                   
                    ' プロットエリアの枠線の色を変更
                    ActiveChart.PlotArea.Select
                    Selection.Format.Line.Visible = msoFalse ' 枠線を不可視に
                    'Selection.Format.Line.ForeColor.RGB = RGB(153, 153, 153) ' 枠線ありの場合
                    ' マーカーの線色と塗り色を変更
                    With ActiveChart.SeriesCollection(1)
                        .MarkerBackgroundColorIndex = xlColorIndexNone ' 塗り色(デフォ:なし)
                        .MarkerForegroundColor = RGB(0, 0, 0) ' 線色
                    End With
                        
            Case Is > y ' 相関行列(マトリクスの右上部を描く)
            
                Set cor = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                axLeft + x * paWidth, axTop + y * paHeight, paWidth, paHeight) ' テキストボックスの作成
            
                With cor ' テキストボックスの書式設定
                    .TextFrame.Characters.Text = Format(r(y, x), "0.00") ' 相関係数をセット(.以下有効2桁)
                    '.TextFrame.Characters.Font.Size = 12 ' フォントサイズ[固定]
                    .TextFrame.Characters.Font.Size = Application.WorksheetFunction.Max(32 * Abs(r(y, x)), 10) ' フォントサイズ[可変](デフォ)
                    .TextFrame2.VerticalAnchor = msoAnchorTop
                    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignRight
                    
                    ' ※※※ 相関係数の強弱に応じて背景を着色する
                    
                    'Select Case r(y, x)
                    '    Case Is > 0 ' 正の相関(赤)
                    '        .Fill.ForeColor.RGB = RGB(255, 255 * (1 - r(y, x)), 255 * (1 - r(y, x)))
                    '    Case 0 ' 無相関(白)
                    '        .Fill.ForeColor.RGB = RGB(255, 255, 255)
                    '    Case Is < 0 ' 負の相関(青)
                    '        .Fill.ForeColor.RGB = RGB(255 * (1 + r(y, x)), 255 * (1 + r(y, x)), 255)
                    'End Select
                    
                    ' ※※※ 相関係数の強弱に応じて背景を着色する ここまで
                    
                End With
            
            Case Is = y ' 変数名(マトリクスの中央対角部を描く)
            
                Set head = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                    axLeft + x * paWidth, axTop + y * paHeight, paWidth, paHeight) ' テキストボックスの作成
                With head ' テキストボックスの書式設定
                    .Fill.ForeColor.RGB = RGB(234, 234, 234) ' 背景色(うすいグレー)
                    .TextFrame.Characters.Text = header(x) ' 変数名を配置
                    '.TextFrame2.TextRange.Font.NameFarEast = "Meiryo UI" ' 使用フォント
                    .TextFrame2.VerticalAnchor = msoAnchorMiddle
                    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                End With
        
        End Select
            
    Next

Next
Application.ScreenUpdating = True
Exit Sub

myError:
    MsgBox "実行時エラーが発生しました。処理を終了します。"
    Application.ScreenUpdating = True
End Sub

Function Margin(Min As Double, Max As Double) As Double
' マージンの計算
Dim MinLength As Double ' 小数点以下の有効桁の抽出用
Dim MaxLength As Double
    If Min = Int(Min) Or Max = Int(Max) Then
        ' 小数点以下の情報を持たない場合の処理
        Margin = Application.WorksheetFunction.Round((Max - Min) * Ratio, 0)
    Else
        ' 小数点以下の情報を持つ場合の処理
        MinLength = Min - Int(Min)
        MaxLength = Max - Int(Max)
        If Len(MinLength) > Len(MaxLength) Then
            Margin = Application.WorksheetFunction.Round((Max - Min) * Ratio, Len(MinLength) - 2)
        Else
            Margin = Application.WorksheetFunction.Round((Max - Min) * Ratio, Len(MaxLength) - 2)
        End If
    End If
End Function

Private Sub X_AXIS(Min As Double, Max As Double, Mgn As Double)
' X軸の最大値と最小値の設定
    With ActiveChart
        .Axes(xlCategory).MinimumScale = Min - Mgn
        .Axes(xlCategory).MaximumScale = Max + Mgn
    End With
End Sub

Private Sub Y_AXIS(Min As Double, Max As Double, Mgn As Double)
' Y軸の最大値と最小値の設定
    With ActiveChart
        .Axes(xlValue).MinimumScale = Min - Mgn
        .Axes(xlValue).MaximumScale = Max + Mgn
    End With
End Sub

Sub SCATTERMATRIX2_combine()
' 図形のグループ化
Dim allShapes As ShapeRange

      ActiveSheet.Shapes.SelectAll
      Set allShapes = Selection.ShapeRange
      allShapes.Group.Select

End Sub

Step 6VBEの操作・VBAコードの導入(4) コードの貼り付け

「標準モジュール」ウインドウにコードを貼り付けます。

Step 7VBEの操作・VBAコードの導入(5)

閉じるボタンをクリックしてVBEを閉じます。

2. マクロの実行

Step 8データ領域の選択

描画したい変数の,ひと続きのデータ範囲を 列見出し(変数名)も含め選択します。

Step 9マクロの実行(1) “SCATTERMATRIX1_draw”

開発タブ「コード」グループのマクロボタンをクリックします。

Step 10マクロの実行(2) “SCATTERMATRIX1_draw”

「マクロ」ダイアログが表示されます。

「マクロ名」に2つのマクロが表示されています。ここでは「SCATTERMATRIX1_draw」の方を選択して,実行ボタンをクリックします。

Step 11マクロの実行(3) “SCATTERMATRIX1_draw”

マクロ「SCATTERMATRIX1_draw」の処理が始まります。データ量ないしはPC等のスペックにしたがって,処理時間が必要となる場合がありますこの処理によりあたらしいブックが作成され,ここに散布図行列が作成されます

Step 12目盛位置の確認

この散布図行列は見かけ上のみ単一で,実態は複数のばらばらのオブジェクト(Graph, Text Box)によって構成されています。

これは,かかる散布図両軸のラベルについても例外でなく,Graphオブジェクトを重ねることによって表現しています。したがって,値の桁数などによっては表示の見切れが生じる可能性があります。この場合,下の図のように個別のオブジェクトを引き出して表示を調整することができます(利用を繰り返すとき,初期設定の値がマッチしないのも都度の修正が面倒だと思います。このような場合,コードの先頭方向の定数adjY, adjXを任意で調整(増やす or 減らす)してください)。

Step 13マクロの実行(1) “SCATTERMATRIX2_combine”

以上の手続きまでに作成されたアウトプットは,エクセルの他のシート ないしはワード・パワーポイントで作る文書にコピー&ペーストして利用することを想定しています。

ただ,この時点でこの散布図行列の構造は結びつきを持たない単独のオブジェクトであって,そうした想定を満たせるものとは言えません。このため,以下で若干の作業を加えます(画像化)。

Step 14マクロの実行(2) “SCATTERMATRIX2_combine”

あたらしく作成されたブックの方の,開発タブ「コード」グループのマクロボタンをクリックします。

Step 15マクロの実行(3) “SCATTERMATRIX2_combine”

「マクロ」ダイアログが表示されます。

「マクロ名」に2つのマクロが表示されています。ここでは「[元のブックのファイル名]!SCATTERMATRIX2_combine」の方を選択して,実行ボタンをクリックします。

Step 16マクロの実行(4) “SCATTERMATRIX2_combine”

マクロが実行され,シート上にあるすべてのオブジェクトがグループ化されます。

Step 17図のコピー(1)

そのまま,ホームタブ「クリップボード」グループのコピーボタン右の三角をクリックし,図としてコピーを選択します。

Step 18図のコピー(2)

「図のコピー」ダイアログが表示されます。

<表示>を「画面に合わせる」,<形式>を「ピクチャ」にして,OKボタンをクリックします。

Step 19図の貼り付け(1)

任意の文書やシート(作成した散布図を用いるドキュメント)の当該箇所をアクティブにし,ホームタブ「クリップボード」グループの貼り付けボタンをクリックします。

Step 20図の貼り付け(2)・完成

図のハンドルを操作し,任意の大きさに整えて完成です。

3.拡張

相関の強弱表現

コードの中の「※」マークで囲まれた領域のコメントアウトを解除して実行すると,相関係数の大きさに応じてテキストボックス(右上半分)の背景色を変更する仕様となります(下図)。

この場合の色の割り当てはRGB(0, 0, 255)~(255, 255, 255)~(255, 0 0)としています(下図)。

[-1]青~[0]白~[1]赤

散布図行列を出力できるexcelアドインソフト

その他の参照