2019/7/2

イントロダクション

このページは散布図の作成と相関係数の計算(相関分析) with Excelの補足ページです。

標準化を経てのラベルつき散布図の作成をVBA(Visual Basic for Applications)にて自動化を試みます。また,アウトプットは4象限マトリクスのひな形として利用できるよう,各象限を平均のプラス域・マイナス域の別に彩色済みです。

免責事項:

  • 掲載のコードは一例として提示しています。諸般のデータに対応するものでも,すべての環境で正常に動作することを保証するものでもありません。
  • [動作確認環境]
    • Windows 7 32bit ServicePack 1 / Excel 2010, 2013(32bit版)
    • Windows 8.1 64bit / Excel 2010, 2013, 2016(32bit版)
    • Windows 10 64bit / Excel 2010, 2013, 2016(32bit版)
  • このコードおよびマクロを利用されたことにより生じた損害,トラブル等につきまして管理者は一切の責任を負いません。

お願い:

  • マクロを利用される場合,万一に備え重要なデータのバックアップをおこなったうえで,事前にテストデータを使って動作を十分に検証されることをおすすめします。

以下,Excel 2010 を使った散布図描画マクロの導入の仕方,および利用の仕方に関する解説です(Excel 2013以降であっても同様の手続きで利用できます。なお,それらのバージョンはラベル表示に限れば標準機能でも対応しています)。

綾子

元データ

元のデータです。

10個のフィールドをもつテストデータです(項目1+変数9)。このうち1つの項目と2つの変数を範囲指定し,マクロを実行してあたらしいシートに散布図を作成します

なおこのマクロは,散布図に

  1. データの標準化
  2. 要素にラベル付け
  3. 象限の色分け

の各処理を加えます。

元データ・vba散布図

VBEを起動する

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

VBE(Visual Basic Editor)が起動します。

メニューの挿入から標準モジュールをクリックすると,エディタにコードウインドウが表示されます。

コードをコピペする

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

Sub ScatterPlot()

' 基準化+象限色分けラベル付散布図の作成 ver.1.0.1
' 2変数を基準化してラベル付の散布図を作成するマクロです。セグメンテーション分析用に象限を色分けしています。
' マクロの実行前に,項目1列と変数2列の 計3列のデータ範囲を指定しておく必要があります。
' 詳細は当該ページ(https://hitorimarketing.net/tools/vba/scatterplot-macro.html)をご覧ください。
' ひとりマーケテイングのためのデータ分析(https://hitorimarketing.net/)
' by hawcas 2013

On Error GoTo myError

Dim LB(1000) As String      ' ラベル
Dim VA(2, 1000) As Variant  ' 元データ
Dim ZS(2, 1000) As Variant  ' 基準値
Dim AV(2) As Variant        ' 平均値
Dim SD(2) As Variant        ' 標準偏差
Dim selRows As Long         ' 選択行数
Dim bpAdd(3) As Variant     ' 系列始点(アドレス)
Dim zsAdd As String         ' z値アドレス
Dim zsMax As Double         ' 基準値最大値
Dim zsMin As Double         ' 基準値最小値
Dim xyLim As Long           ' 軸上(下)限
Dim Target As Range
Dim intRng As String
Dim tmp As String
Dim FLG1 As Boolean
Dim FLG2 As Boolean

Dim x As Long               ' 以下カウンタ
Dim y As Long
Dim e1Chkr As Long          ' 以下エラーチェッカー
Dim e2aChkr(3) As Long
Dim e2bChkr(3) As Long

Set Target = Selection
intRng = Target.Address     ' 選択アドレス
selRows = Range(intRng).Rows.Count    ' 項目数

' 系列の特定とシートの作成 -----------------------------*
Select Case Len(Target.Address) - Len(Replace(Target.Address, ",", ""))
Case 0  ' 選択範囲が連続
    If Range(intRng).Columns.Count <> 3 Then  ' エラー(1)チェック
        Call xErr1
        Exit Sub
    End If
    bpAdd(1) = Mid(intRng, 1, InStr(intRng, ":") - 1)
    bpAdd(2) = Range(bpAdd(1)).Offset(0, 1).Address
    bpAdd(3) = Range(bpAdd(1)).Offset(0, 2).Address
    
Case 1  ' 選択範囲が不連続な2つの領域
    e1Chkr = 0
    With Selection ' エラー(1)チェック
        For y = 1 To .Areas.Count
            e1Chkr = e1Chkr + .Areas(y).Columns.Count
        Next
    End With
    If e1Chkr <> 3 Then
        Call xErr1
        Exit Sub
    End If
    
    With Selection  ' エラー(2)チェック
         For y = 1 To .Areas.Count
             e2aChkr(y) = .Areas(y).Rows.Count  ' 項目チェック
             e2bChkr(y) = .Areas(y).Row         ' 対応チェック
         Next
    End With
    If e2aChkr(1) <> e2aChkr(2) Or e2bChkr(1) <> e2bChkr(2) Then
        Call xErr2
        Exit Sub
    End If
    
    With Selection
        If .Areas(1).Column > .Areas(2).Column Then
            FLG1 = True
        End If
    End With
    bpAdd(1) = Mid(intRng, 1, InStr(intRng, ",") - 1)
    tmp = Mid(intRng, InStr(intRng, ",") + 1)
    bpAdd(3) = tmp
    If FLG1 = True Then
        tmp = bpAdd(1)
        bpAdd(1) = bpAdd(3)
        bpAdd(3) = tmp
    End If
    If Range(bpAdd(1)).Columns.Count = 2 Then
        FLG2 = True
    End If
    bpAdd(1) = Mid(bpAdd(1), 1, InStr(bpAdd(1), ":") - 1)
    bpAdd(3) = Mid(bpAdd(3), 1, InStr(bpAdd(3), ":") - 1)
    If FLG2 = True Then
        bpAdd(2) = Range(bpAdd(1)).Offset(0, 1).Address
    Else
        bpAdd(2) = bpAdd(3)
        bpAdd(3) = Range(bpAdd(3)).Offset(0, 1).Address
    End If
   
Case Is > 1 ' 選択範囲が不連続な3つの領域
    e1Chkr = 0
    With Selection  ' エラー(1)チェック
        For y = 1 To .Areas.Count
            e1Chkr = e1Chkr + .Areas(y).Columns.Count
        Next
    End With
    If e1Chkr <> 3 Then
        Call xErr1
        Exit Sub
    End If

    With Selection  ' エラー(2)チェック
        For y = 1 To .Areas.Count
            e2aChkr(y) = .Areas(y).Rows.Count   ' 項目チェック
            e2bChkr(y) = .Areas(y).Row          ' 対応チェック
        Next
    End With
    
    If e2aChkr(1) <> e2aChkr(2) Or e2aChkr(1) <> e2aChkr(3) Or _
        e2aChkr(2) <> e2aChkr(3) Or _
         e2bChkr(1) <> e2bChkr(2) Or e2bChkr(1) <> e2bChkr(3) Or _
          e2bChkr(2) <> e2bChkr(3) Then
        Call xErr2
        Exit Sub
    End If
    bpAdd(1) = Left(intRng, InStr(intRng, ",") - 1)
    tmp = Mid(intRng, InStr(intRng, ",") + 1)
    tmp = Mid(tmp, InStr(tmp, ",") + 1)
    bpAdd(3) = tmp
    intRng = Replace(intRng, bpAdd(1), "")
    intRng = Replace(intRng, bpAdd(3), "")
    intRng = Replace(intRng, ",", "")
    bpAdd(2) = intRng
    bpAdd(1) = Mid(bpAdd(1), 1, InStr(bpAdd(1), ":") - 1)
    bpAdd(2) = Mid(bpAdd(2), 1, InStr(bpAdd(2), ":") - 1)
    bpAdd(3) = Mid(bpAdd(3), 1, InStr(bpAdd(3), ":") - 1)
    Call ValSort(bpAdd)
    
End Select

' ラベルの読み込み
For y = 1 To selRows
    LB(y) = Range(bpAdd(1)).Offset(y - 1, 0).Value
Next
' 変数1の読み込み
For y = 1 To selRows
    VA(1, y) = Range(bpAdd(2)).Offset(y - 1, 0).Value
    If IsNumeric(VA(1, y)) = False Or IsEmpty(VA(1, y)) = True Then ' エラー(3)チェック
        Call xErr3
        Exit Sub
    End If
Next
' 変数2の読み込み
For y = 1 To selRows
    VA(2, y) = Range(bpAdd(3)).Offset(y - 1, 0).Value
    If IsNumeric(VA(2, y)) = False Or IsEmpty(VA(1, y)) = True Then ' エラー(3)チェック
        Call xErr3
        Exit Sub
    End If
Next

' シートの追加
Worksheets.Add

' ラベルの転記
For y = 1 To selRows
     Range("A2").Offset(y - 1, 0).Value = LB(y)
Next
Range("B1").Value = "VA1"
Range("C1").Value = "VA2"
' 変数1の転記
For y = 1 To selRows
    Range("B2").Offset(y - 1, 0).Value = VA(1, y)
Next
' 変数2の転記
For y = 1 To selRows
    Range("C2").Offset(y - 1, 0).Value = VA(2, y)
Next
' ------------------------------------------------------*

' 見出しと計算式の記述 ---------------------------------*
' 平均・標準偏差・max.・min.・Dummy
Range("A1").Offset(selRows + 2, 0).Value = "平均"
Range("B1").Offset(selRows + 2, 0).Formula = _
        "=average($B$2:" & Range("B2").Offset(selRows - 1, 0).Address & ")"
Range("C1").Offset(selRows + 2, 0).Formula = _
        "=average($C$2:" & Range("C2").Offset(selRows - 1, 0).Address & ")"
Range("A1").Offset(selRows + 3, 0).Value = "標準偏差"
Range("B1").Offset(selRows + 3, 0).Formula = _
        "=stdevp($B$2:" & Range("B2").Offset(selRows - 1, 0).Address & ")"
Range("C1").Offset(selRows + 3, 0).Formula = _
        "=stdevp($C$2:" & Range("C2").Offset(selRows - 1, 0).Address & ")"
Range("A1").Offset(selRows + 4, 0).Value = "Max."
Range("D1").Offset(selRows + 4, 0).Formula = _
        "=max($D$2:" & Range("$D$2").Offset(selRows - 1, 0).Address & ")"
Range("E1").Offset(selRows + 4, 0).Formula = _
        "=max($E$2:" & Range("$E$2").Offset(selRows - 1, 0).Address & ")"
Range("A1").Offset(selRows + 5, 0).Value = "Min."
Range("D1").Offset(selRows + 5, 0).Formula = _
        "=min($D$2:" & Range("$D$2").Offset(selRows - 1, 0).Address & ")"
Range("E1").Offset(selRows + 5, 0).Formula = _
        "=min($E$2:" & Range("$E$2").Offset(selRows - 1, 0).Address & ")"
Range("A1").Offset(selRows + 7, 0).Value = "Dummy1"
Range("B1").Offset(selRows + 7, 0).Value = "Dummy2"
Range("A1").Offset(selRows + 8, 0).Value = "1"
Range("B1").Offset(selRows + 8, 0).Value = "1"
Range("A1").Offset(selRows + 9, 0).Value = "1"
Range("B1").Offset(selRows + 9, 0).Value = "1"
' 基準値
Range("D1").Value = "z1"
Range("E1").Value = "z2"
intRng = "=standardize(B2," & Range("B1").Offset(selRows + 2, 0).Address & "," & _
    Range("B1").Offset(selRows + 3, 0).Address & ")"
Range("D2").Formula = intRng
intRng = "=standardize(C2," & Range("C1").Offset(selRows + 2, 0).Address & "," & _
    Range("C1").Offset(selRows + 3, 0).Address & ")"
Range("E2").Formula = intRng
zsAdd = "$D$2:" & _
    Range("D2").Offset(selRows - 1, 1).Address ' z値領域
Range("D2:E2").Copy
Range(zsAdd).PasteSpecial
' -----------------------------------------------------*

' 散布図の作成 ----------------------------------------*
' 軸調整(計算
zsMax = Application.WorksheetFunction.Max(Range(Range("D1").Offset(selRows + 4, 0).Address, _
    Range("E1").Offset(selRows + 5, 0).Address))
zsMin = Application.WorksheetFunction.Min(Range(Range("D1").Offset(selRows + 4, 0).Address, _
    Range("E1").Offset(selRows + 5, 0).Address))
If zsMax > Abs(zsMin) Then
    xyLim = Application.WorksheetFunction.RoundUp(zsMax, 0)
Else
    xyLim = Application.WorksheetFunction.RoundUp(Abs(zsMin), 0)
End If
' グラフ描画
ActiveSheet.Shapes.AddChart(xlXYScatter, , , 310, 295).Select  ' グラフ幅310pt, グラフ高さ295pt
ActiveChart.SetSourceData Source:=Range(zsAdd) ' データ範囲の指定
With ActiveChart.SeriesCollection(1)
    .MarkerStyle = xlMarkerStyleCircle ' マーカースタイルの指定(初期設定は円形マーカー)
        ' xlMarkerStyleSquare(四角形),xlMarkerStyleDiamond(ひし形),
        ' xlMarkerStyleTriangle(三角形),xlMarkerStyleX(X),
    .MarkerSize = 7
    .MarkerBackgroundColor = RGB(255, 255, 255) ' マーカーの塗りつぶしの色
    .MarkerForegroundColor = RGB(23, 23, 23) ' マーカーの線の色
End With
           
' ※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
' ラベル付加(ラベル不要の場合「※」で挟まれた部分のコードを削除)
With ActiveChart.SeriesCollection(1)
    .HasDataLabels = True
    .DataLabels.Position = xlLabelPositionRight ' ラベルの位置(初期設定は右)
        ' xlLabelPositionAbove(上),xlLabelPositionBelow(下),
        ' xlLabelPositionLeft(左),xlLabelPositionCenter(中央)
    .DataLabels.Font.Color = RGB(96, 96, 96) ' ラベルフォントの色
    For x = 2 To selRows + 1
        .Points(x - 1).DataLabel.Text = "=" & ActiveSheet.Name & "!$A$" & x
    Next
End With
' ※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※

' 軸の調整
With ActiveChart
    .SetElement (msoElementPrimaryValueGridLinesNone)
    .HasLegend = False
End With
With ActiveChart.Axes(xlCategory)
    .MinimumScale = xyLim * -1
    .MaximumScale = xyLim
    .MajorUnit = 1
    .MajorTickMark = xlCross
    .TickLabels.Font.Color = RGB(99, 108, 118)
End With
With ActiveChart.Axes(xlValue)
    .MinimumScale = xyLim * -1
    .MaximumScale = xyLim
    .MajorUnit = 1
    .MajorTickMark = xlCross
    .TickLabels.Font.Color = RGB(99, 108, 118)
End With
' 象限作成
ActiveSheet.ChartObjects(1).Chart.SeriesCollection.Add _
    Source:=ActiveSheet.Range(Range("A1").Offset(selRows + 7, 0).Address, _
    Range("B1").Offset(selRows + 9, 0).Address), rowcol:=xlColumns, _
    serieslabels:=True  ' ダミー系列を追加
With ActiveChart.SeriesCollection(2)
    .AxisGroup = 2
    .ChartType = xlColumnStacked100
End With
With ActiveChart.SeriesCollection(3)
    .AxisGroup = 2
    .ChartType = xlColumnStacked100
End With
ActiveChart.ChartGroups(1).GapWidth = 0
With ActiveChart.Axes(xlValue, xlSecondary) ' 第2軸を不可視に
    .MajorTickMark = xlNone
    .TickLabelPosition = xlNone
    .Format.Line.Visible = msoFalse
End With
' 象限彩色
ActiveSheet.ChartObjects(1).Activate
ActiveChart.SeriesCollection(3).Points(2).Interior.Color = _
        RGB(255, 255, 255)  ' 第1象限の色(初期値は白)
ActiveChart.SeriesCollection(2).Points(2).Interior.Color = _
        RGB(234, 234, 234) ' 第4象限の色(初期値は淡いグレー)
ActiveChart.SeriesCollection(3).Points(1).Interior.Color = _
        RGB(234, 234, 234)  ' 第2象限の色(初期値は淡いグレー)
ActiveChart.SeriesCollection(2).Points(1).Interior.Color = _
        RGB(212, 212, 212)  ' 第3象限の色(初期値は濃いグレー)
    
Excel.Application.CutCopyMode = False ' クリップボードの内容を消去
' ------------------------------------------------------*
Exit Sub

myError:
   MsgBox "実行時エラーが発生しました。処理を終了します。", vbExclamation + vbOKOnly

End Sub

Sub ValSort(ByRef val() As Variant)
' Case3に係るソート
Dim tmp(3) As Variant
Dim vx As Variant
Dim i As Long
Dim j As Long

For i = 1 To 3
    tmp(i) = val(i)
Next

For i = 1 To 3
    For j = 3 To i Step -1
        If Range(tmp(i)).Column > Range(tmp(j)).Column Then
            vx = tmp(i)
            tmp(i) = tmp(j)
            tmp(j) = vx
        End If
    Next
Next
   
For i = 1 To 3
    val(i) = tmp(i)
Next

End Sub

Private Sub xErr1()
    ' エラー(1)
    MsgBox "項目1列と変数2列の 計3列のデータ範囲を指定してください。", vbExclamation + vbOKOnly
End Sub

Private Sub xErr2()
    ' エラー(2)
    MsgBox "データが対になるよう範囲を指定してください。", vbExclamation + vbOKOnly
End Sub

Private Sub xErr3()
    ' エラー(3)
    MsgBox "選択した変数系列に数値以外(または空白)が含まれています。", vbExclamation + vbOKOnly
End Sub

コピーしたコードを,コードウインドウに貼り付けます。

コードが導入出来たので,VBEを閉じます。

では,ここからマクロの具体的な使い方です。

データ範囲を指定する

晴花

マクロの実行前に,データ範囲を指定しておきます。

ラベルとして使用する項目を1列,変数を2列の計3列のデータを,見出しを除いて選択します。このマクロは,選択した列の中でも最も左端の列をラベルとして使用します

連続する領域だけでなく[下図(1)],離れた領域でも指定できます[同(2)]。ただし下図(3)のように,

  • 計3列でない
  • 指定範囲が対でない
  • 指定範囲に文字(項目列は除く)または空白が含まれる

ような指定からでは,マクロは正常に動作しません。

(1)
(2)
(3)

マクロを実行する

ということで,指定を済ませたら,リボンの開発タブコードグループのマクロボタンをクリックします。

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

マクロ名に「ScatterPlot」(このマクロの名前)が表示されていることを確認して,実行ボタンをクリックします。

下のような散布図をあたらしいシートに自動でアウトプットします。

ここにラベルの位置調整(要素の位置によってはラベルが重なります)など,適宜任意の加工をくわえていきます。