ExcelVBAによる、ラベル付き標準化散布図［＋セグメント色分け］の描画。

COPY ALL

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