ひとりマーケティングのためのデータ分析

手順解説 | Excel(エクセル)でおこなうビジネスデータの分析

VBA
How-to

基準化・象限色分け・ラベル付

散布図

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

機能的には簡易なものですが、手続きが煩雑な基準化を経てのラベルつき散布図の作成を VBA(Visual Basic for Applications)にて自動化する一例です。また、セグメンテーション分析に利用できるよう各象限は彩色済みです。

以下、Excel 2010 を使った VBA による散布図作成マクロの導入方法です。Excel 2007, Excel 2013 および Excel 2016 でもそのままの手続きで利用できます(ただし 2013 以降の場合、標準機能でも項目のラベル表示が可能です)。


免責事項

  • 掲載するコードは煩雑な手続きをサポートする一例として提示するものです。諸般のデータに対応するものでも、すべての環境で正常に動作することを保証するものでもありません。

[動作確認環境]

  • Windows 7 32bit ServicePack 1 / Excel 2007, 2010, 2013(32bit版)
  • Windows 8.1 64bit / Excel 2007, 2010, 2013, 2016(32bit版)
  • このマクロは結果の精度を保証するものではありません。またこのコードおよびマクロを利用されたことにより生じた損害、トラブル等につきまして管理者は一切の責任を負いません。

お願い

  • お手持ちのデータでマクロをご利用いただく前に、サンプルデータを使って動作をご検証ください。サンプルデータはサイドバーのリンク先にあります。また、マクロの実行前には、万一に備え大切なデータのバックアップをおこなっていただけますようお願い申し上げます。

元データ

綾子

1

元のデータです。

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

なお、この散布図には

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

の各処理が自動的になされます。


※ データはサイドバーのボタンからご利用いただけます。

scrollable

元データ・vba散布図

VBEを起動する

綾子

2

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

綾子

3

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

メニューの挿入から標準モジュールをクリックすると、エディタにコードウインドウが表示されます。こちらにコードを記入していくことになります。

コードをコピペする

綾子

4

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

Sub ScatterPlot()

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

綾子

5

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

綾子

6

以上でコードが導入できました。VBE を閉じます。

では、ここからは散布図作成マクロの具体的な使い方です。

データ範囲を指定する

晴花

7

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

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

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

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

ような指定はできません。

(1)

(2)

(3)

マクロを実行する

晴花

8

…ということで、指定ができたら、リボンの開発タブコードグループにあるマクロボタンをクリックします。

晴花

9

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

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

晴花

10

すると、下のような散布図があたらしいシートに自動的に作成されます。

必要によって、ラベルの位置調整(要素の位置によってはラベルが重なります)など適宜加工してください。

  • 本頁で使用したデータはすべて架空のものです。また特定の会社等に実在する人物名、および同場所で実際に観測されたデータ群などを根拠にしたものでもありません。
.

LastUpdate

2016.7.12

.
このページの先頭へ