Excel VBAで層別散布図を作成するマクロを作ってみた2
前回、2通りある層別散布図の作成方法から、「系列を追加する」方法を選択してマクロを作ることにしました。記事の段取りはいつもどおりです。
ソースコード
'層別散布図を作成する
Sub Stratified_Scatter_Plot()
Dim i As Integer, j As Integer
Dim RNG(3) As Range
Dim ChrtRow As Long
Dim ChrtClm(1 To 3) As String
Dim ChrtSrc(1 To 2) As String
If Selection.Count <> 3 Then
MsgBox "セルは必ず3つ選択してください。", vbCritical, "層別散布図"
ElseIf Selection.Row <> 1 Then
MsgBox "セルは必ず一行目(タイトル行)を選択してください。", vbCritical, "層別散布図"
Else
For Each RNG(0) In Selection
i = i + 1
Set RNG(i) = RNG(0)
Next
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=RNG(1)
.SetRange RNG(1).CurrentRegion
.Header = xlYes
.Apply
End With
ChrtRow = 2: j = 1
For i = 1 To 3
ChrtClm(i) = Left(RNG(i).Address, 3)
Next
For i = 3 To RNG(1).End(xlDown).Row + 1
If Cells(i, RNG(1).Column).Value <> Cells(i - 1, RNG(1).Column).Value Then
ChrtSrc(1) = "'" & ActiveSheet.Name & "'!" & ChrtClm(2) & ChrtRow & _
":" & ChrtClm(2) & i - 1
ChrtSrc(2) = "'" & ActiveSheet.Name & "'!" & ChrtClm(3) & ChrtRow & _
":" & ChrtClm(3) & i - 1
If ChrtRow = 2 Then
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
ActiveChart.SetSourceData Source:=Range(ChrtSrc(1) & "," & ChrtSrc(2))
ActiveChart.FullSeriesCollection(1).Name = _
"='" & ActiveSheet.Name & "'!" & ChrtClm(1) & ChrtRow
Else
j = j + 1
With ActiveChart
.SeriesCollection.NewSeries
.FullSeriesCollection(j).Name = _
"='" & ActiveSheet.Name & "'!" & ChrtClm(1) & ChrtRow
.FullSeriesCollection(j).XValues = "=" & ChrtSrc(1)
.FullSeriesCollection(j).Values = "=" & ChrtSrc(2)
End With
End If
ChrtRow = i
End If
Next
With ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Text = RNG(2).Value
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Text = RNG(3).Value
.SetElement (msoElementLegendRight)
End With
End If
End Sub
コードのポイント解説
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=RNG(1) .SetRange RNG(1).CurrentRegion
.Header = xlYes
.Apply
End With
まず、属性の列をキーとしてデータを並べ替えます。
なるべく元データを弄りたくはありませんが、これだけは必須なので。
For i = 3 To RNG(1).End(xlDown).Row + 1
If Cells(i, RNG(1).Column).Value <> Cells(i - 1, RNG(1).Column).Value Then
3行目から最終行+1行目までのループの中で、キー列(属性)の値が変わる境目で処理を実行します。
If ChrtRow = 2 Then
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
ActiveChart.SetSourceData Source:=Range(ChrtSrc(1) & "," & ChrtSrc(2))
ActiveChart.FullSeriesCollection(1).Name = _
"='" & ActiveSheet.Name & "'!" & ChrtClm(1) & ChrtRow
Else
j = j + 1
With ActiveChart .SeriesCollection.NewSeries
.FullSeriesCollection(j).Name = _
"='" & ActiveSheet.Name & "'!" & ChrtClm(1) & ChrtRow
.FullSeriesCollection(j).XValues = "=" & ChrtSrc(1)
.FullSeriesCollection(j).Values = "=" & ChrtSrc(2)
End With
End If
1番目の属性のデータ範囲でグラフ(散布図)を作成します。
2番目以降の属性のデータ範囲で系列を追加します。
With ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Text = RNG(2).Value
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Text = RNG(3).Value
.SetElement (msoElementLegendRight)
End With
最後に、軸ラベルと凡例を追加します。
使い方と実行結果
使用上の注意
- 1行目は必ずタイトル行にしてください。
- 属性の列は必ず一番左に配置してください。
- 属性の列に欠損値があると正常に動作しません。
使い方
- ソースコード全行をVBEで標準モジュールにコピペししてください。
- 1行目(タイトル行)でセルを3つ選択してください。
左:属性 真ん中:横軸 右:縦軸 となります。 - [開発]→[マクロ]→[Stratified_Scatter_Plot]を選択→【実行】をクリックしてください。
実行結果
一瞬で、層別散布図が作成されます。
書式とかは適宜、手を加えてください。