元データ

10フィールド（項目1＋変数9）のテストデータです。このうち1列の項目と2列の変数、計3列を範囲指定してマクロを実行すると、新しいシートに散布図が作成されます。マクロは次の3つの処理を自動で行います。

データの標準化（z スコア変換）
要素へのラベル付け
4象限の色分け

02

VBE を起動してコードをコピペする

リボンの開発タブ → コードグループの Visual Basic をクリックして VBE を起動します。メニューの挿入 → 標準モジュールでコードウィンドウを表示します。

下のコードをすべてコピーし、コードウィンドウに貼り付けます。VBE を閉じます。



'===============================================================================
' 基準化＋象限色分けラベル付散布図 作成マクロ
' サイト     : hitorimarketing.net/tools/vba/scatterplot-macro.html
' 作成者     : hawcas
' 作成年     : 2013
'===============================================================================
'
' 【概要】
'   2変数を基準化（z スコア化）してラベル付きの散布図を作成する。
'   セグメンテーション分析用に4象限を色分けする。
'
' 【使い方】
'   1. 元データシートで「項目列 1 列 ＋ 変数列 2 列」の計 3 列を選択する。
'      選択形式は連続・不連続（2 領域・3 領域）のいずれにも対応。
'   2. ScatterPlot を実行する。
'   3. 新規シートに基準値データとグラフが生成される。
'
' 【新規シートのセルレイアウト】
'   A2〜A列  : ラベル（項目名）
'   B列      : VA1（変数1の元データ）
'   C列      : VA2（変数2の元データ）
'   D列      : z1（変数1の基準値）
'   E列      : z2（変数2の基準値）
'   A/B/C の selRows+3 行目以降 : 平均・標準偏差・Max・Min の集計行
'   A/B の selRows+8 行目以降   : 象限描画用ダミー系列データ
'
' 【エラー一覧】
'   xErr1 : 選択列数が 3 列でない
'   xErr2 : 不連続選択で行数または開始行が一致しない（データが対になっていない）
'   xErr3 : 変数列に非数値または空白が含まれている
'
' 【モジュール構成】
'   Sub ScatterPlot   メイン処理（選択範囲解析 → シート生成 → グラフ描画）
'   Sub ValSort       3 領域不連続選択時の列順ソート（ScatterPlot から呼ばれる）
'   Sub xErr1〜xErr3  エラーメッセージ表示（ScatterPlot から呼ばれる）
'===============================================================================


'===============================================================================
' Sub : ScatterPlot
' 概要 : メイン処理。
'        選択範囲を解析して「項目列・変数1列・変数2列」を特定し、
'        新規シートに元データ・基準値・統計量を書き出してから
'        基準化散布図（象限色分け＋ラベル付き）を生成する。
' 前提 : 元データシートで項目 1 列＋変数 2 列（計 3 列）を選択してから実行。
'        選択形式は連続・不連続（2 領域・3 領域）に対応。
'===============================================================================
Sub ScatterPlot()

On Error GoTo myError

'--- 配列・変数の宣言 ---
Dim LB(1000) As String      ' ラベル（項目名）
Dim VA(2, 1000) As Variant  ' 元データ（VA(1,*)=変数1, VA(2,*)=変数2）
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     ' 各列の先頭セルアドレス（1=項目, 2=変数1, 3=変数2）
Dim zsAdd As String         ' 基準値領域（D2:E末尾）のアドレス文字列
Dim zsMax As Double         ' 基準値の最大値（軸上限計算用）
Dim zsMin As Double         ' 基準値の最小値（軸下限計算用）
Dim xyLim As Long           ' 軸の上限・下限（絶対値; ±xyLim で対称軸を作る）
Dim Target As Range         ' 選択範囲オブジェクト
Dim intRng As String        ' 選択アドレス文字列（作業用）
Dim tmp As String           ' 汎用一時文字列
Dim FLG1 As Boolean         ' 2領域選択時: 左右の順序が逆かどうかのフラグ
Dim FLG2 As Boolean         ' 2領域選択時: 最初の領域が 2 列（項目+変数1）かどうかのフラグ

Dim x As Long               ' ループカウンタ（ラベル設定用）
Dim y As Long               ' ループカウンタ（汎用）
Dim e1Chkr As Long          ' エラー(1)チェック用: 合計列数の集計
Dim e2aChkr(3) As Long      ' エラー(2)チェック用: 各領域の行数
Dim e2bChkr(3) As Long      ' エラー(2)チェック用: 各領域の開始行番号

Set Target = Selection
intRng  = Target.Address
selRows = Range(intRng).Rows.Count

'===========================================================================
' 選択範囲の解析と bpAdd の確定
'   intRng 内のカンマ数で選択領域の個数を判定し、
'   bpAdd(1)=項目列先頭, bpAdd(2)=変数1列先頭, bpAdd(3)=変数2列先頭 を設定する。
'   列の並び順は左から 項目・変数1・変数2 に統一する（ValSort で保証）。
'===========================================================================
Select Case Len(Target.Address) - Len(Replace(Target.Address, ",", ""))

'--- Case 0: 連続した 3 列選択 ---
Case 0
    If Range(intRng).Columns.Count <> 3 Then
        Call xErr1  ' 列数が 3 でなければエラー
        Exit Sub
    End If
    ' 先頭セルから右へ 0・1・2 列オフセットで各列を特定
    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 領域選択（例: A:A, C:D など）---
Case 1
    '- エラー(1): 2 領域の列数合計が 3 でなければエラー
    e1Chkr = 0
    With Selection
        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

    '- エラー(2): 領域間で行数または開始行が異なればエラー（データが対になっていない）
    With Selection
        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

    '- 右領域が先に選択されている場合（FLG1=True）は後で左右を入れ替える
    With Selection
        If .Areas(1).Column > .Areas(2).Column Then FLG1 = True
    End With

    '- アドレス文字列を "," で分割して bpAdd(1)・bpAdd(3) に仮割り当て
    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

    '- FLG2: bpAdd(1) が 2 列の場合は 項目+変数1 がまとめて選ばれている
    If Range(bpAdd(1)).Columns.Count = 2 Then FLG2 = True

    '- 各 bpAdd を先頭セルアドレスに整理
    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 ' 変数1は項目列の 1 つ右
    Else
        bpAdd(2) = bpAdd(3)
        bpAdd(3) = Range(bpAdd(3)).Offset(0, 1).Address ' 変数2は変数1の 1 つ右
    End If

'--- Case 2以上: 不連続な 3 領域選択（各列を個別に選択）---
Case Is > 1
    '- エラー(1): 3 領域の列数合計が 3 でなければエラー
    e1Chkr = 0
    With Selection
        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

    '- エラー(2): いずれかの領域間で行数または開始行が異なればエラー
    With Selection
        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)〜(3) に仮割り当て
    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 を先頭セルアドレスに整理
    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) ' 列番号順（左から 項目・変数1・変数2）に並び替え

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
        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
        Call xErr3
        Exit Sub
    End If
Next

'===========================================================================
' 新規シートの生成とデータの転記
'===========================================================================
Worksheets.Add

' ラベル列（A2〜）
For y = 1 To selRows
    Range("A2").Offset(y - 1, 0).Value = LB(y)
Next

' 変数ヘッダーと値の転記
Range("B1").Value = "VA1"
Range("C1").Value = "VA2"
For y = 1 To selRows
    Range("B2").Offset(y - 1, 0).Value = VA(1, y)
Next
For y = 1 To selRows
    Range("C2").Offset(y - 1, 0).Value = VA(2, y)
Next

'===========================================================================
' 集計行・基準値・ダミー系列の書き込み
'   基準値の STANDARDIZE 式は D2:E2 に入力後、zsAdd 領域にコピーする。
'   ダミー系列（Dummy1/Dummy2 の 2 行 2 列）は象限塗り分け用の
'   100% 積み上げ縦棒グラフのデータソースとして使用する。
'===========================================================================
' 平均・標準偏差・Max・Min の集計行
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 & ")"

' 象限塗り分け用ダミー系列（1行2列の定数ブロックを2行分）
' 系列2（Dummy1）と系列3（Dummy2）の2系列を 100% 積み上げ縦棒に使う
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"

' 基準値（STANDARDIZE 式を D2:E2 に入力し、全データ行にコピー）
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 ' 基準値領域（z1・z2 全行）
Range("D2:E2").Copy
Range(zsAdd).PasteSpecial

'===========================================================================
' 散布図の生成
'===========================================================================
'--- 軸上下限の計算：z1・z2 の絶対値最大を切り上げて ±xyLim の対称軸にする ---
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, Diamond, Triangle, X）
    .MarkerSize  = 7
    .MarkerBackgroundColor = RGB(255, 255, 255) ' マーカー塗りつぶし色
    .MarkerForegroundColor = RGB(23, 23, 23)   ' マーカー枠線色
End With

' ※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
' ラベルの付加（ラベル不要の場合は「※」で挟まれたブロックをまるごと削除）
With ActiveChart.SeriesCollection(1)
    .HasDataLabels = True
    .DataLabels.Position = xlLabelPositionRight ' ラベル位置（変更例: Above, Below, Left, Center）
    .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
' ※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※

'--- X・Y 軸の共通設定（対称スケール・目盛り・ラベル色）---
With ActiveChart
    .SetElement (msoElementPrimaryValueGridLinesNone) ' 横目盛線（グリッドライン）を非表示
    .HasLegend = False
End With
With ActiveChart.Axes(xlCategory) ' X 軸
    .MinimumScale = xyLim * -1
    .MaximumScale = xyLim
    .MajorUnit    = 1
    .MajorTickMark = xlCross       ' 目盛り線を内外両方向に表示
    .TickLabels.Font.Color = RGB(99, 108, 118)
End With
With ActiveChart.Axes(xlValue)    ' Y 軸
    .MinimumScale = xyLim * -1
    .MaximumScale = xyLim
    .MajorUnit    = 1
    .MajorTickMark = xlCross
    .TickLabels.Font.Color = RGB(99, 108, 118)
End With

'===========================================================================
' 象限の生成
'   ダミー系列（Dummy1/Dummy2）を 100% 積み上げ縦棒グラフ（第2軸）として追加し、
'   各棒の 2 点（= 2 行）を上下の象限に対応させて色を塗り分ける。
'     系列2（Dummy1）: 点1=第2象限, 点2=第1象限
'     系列3（Dummy2）: 点1=第3象限, 点2=第4象限
'   ※ 積み上げ縦棒の「左の棒」が X<0 側, 「右の棒」が X>0 側に相当
'===========================================================================
'--- ダミー系列の追加と 100% 積み上げ縦棒（第2軸）への変換 ---
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 ' 棒の間隔をゼロにして象限をすき間なく並べる

'--- 第2軸を非表示（象限表示の補助のみに使用し、軸自体は見せない）---
With ActiveChart.Axes(xlValue, xlSecondary)
    .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
' 概要 : bpAdd(1〜3) を列番号の昇順（左→右）に並び替える。
'        3 領域不連続選択時に列の選択順を問わず、
'        「項目・変数1・変数2」の正しい順序を保証するために使用する。
' 引数 : val() - 先頭セルアドレスの配列（ByRef で呼び出し元に反映）
'===============================================================================
Sub ValSort(ByRef val() As Variant)

Dim tmp(3) As Variant ' ソート作業用の一時配列
Dim vx     As Variant ' 要素の入れ替え用バッファ
Dim i      As Long    ' 外側ループカウンタ
Dim j      As Long    ' 内側ループカウンタ（バブルソートの比較対象）

' val をローカル配列にコピーしてからバブルソート（列番号の昇順）
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


'===============================================================================
' エラーメッセージ表示用サブルーチン（ScatterPlot から呼ばれる）
'   xErr1 : 選択列数が 3 でない
'   xErr2 : 不連続選択でデータが対になっていない（行数または開始行が不一致）
'   xErr3 : 変数列に非数値または空白が含まれている
'===============================================================================
Private Sub xErr1()
    MsgBox "項目1列と変数2列の 計3列のデータ範囲を指定してください。", vbExclamation + vbOKOnly
End Sub

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

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