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

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

VBA
How-to

統計パッケージのような
スッキリスマート!を必要とするときの,VBAでつくる

ヒストグラム

このページはヒストグラムの作成 with Excelの補足ページです。

イメージした表現力豊かなグラフが,たいした困難も伴わず,あろうことか画面を眺めながらの直感的な試行錯誤で手に入れられる,といった利点―――ある意味これはChartjunkの領域にユーザーを誘う凶器ともなりえますが―――は,是非はともかくエクセルの最大の武器のひとつだと思います。

しかしヒストグラムに関しては―――ver.2016の新機能を含め,ふだん,なかなか積極的な評価の声を聞くことが難しいようにも感じます。そもそもヒストグラムは,ユーザーの立ち位置によってその求められる書式や仕様といったものが大きく振れるので,それがゆえの宿命のようなものを元来背負わざるを得ない存在なのかもしれません。

とはいえ,そうした点を割り引いたとしても見にくいものは見にくい―――といった点は否定しがたく,とりわけ同じデータを他の処理系に通したときには,心に複雑な感情が芽生えます。

このページのマクロは,そうした感情を背景に「なら,Excelでスッキリスマート!を再現できるか」を試みるものです。……ということで,世間的にはおそらくバッドノウハウの範疇に属するものです。

以下,Excel 2016を使ったVBAによるヒストグラム作成マクロの導入方法です(Excel 2013およびExcel 2010でも利用できます)。


免責事項

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

[動作確認環境]

  • Windows 10 64bit / Excel 2010, 2013, 2016(すべて32bit版)
  • このコードおよびマクロを利用されたことにより生じた損害,トラブル等につきまして管理者は一切の責任を負いません。

お願い

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

元データと成果物

綾子

1

元のデータです。

例示にあたってちょうどよさげな次の正規乱数を利用します。

  • [n] 300
  • [x bar] 4.982
  • [sd(n-1)] 1.030

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

元データ・ヒストグラム

綾子

2

このマクロは,2 種の形式のグラフを成果物とします。

そのひとつ,下の図のような形式のものを「type 1」と呼ぶことにします。

type 1では,エクセル標準の組み込みグラフである「集合縦棒」と「散布図」の利点をともに使うことができるような状態を用意することで,いずれか片方のみではなしえない,次のような設定を可能にしていきます。

  • 境界値により横軸を描画する
  • 横軸の目盛間隔を任意で決める(複数の階級をまたいで間隔をとる)

type 1では,別頁「ヒストグラムの作成 with Excel Tips1 [境界値のラベルを階級の間に表示させる]」での考え方をベースとしています。

type1

綾子

3

もうひとつ,「type 2」は下の図のような形式のものを指して言うこととします。

type 2ではtype 1の特徴に加え,さらに次のような設定も可能にしていきます。

  • 柱と縦横の軸線とに間隙を挟む
  • 横軸について,表示上の始点と実際の(書式設定上の)始点との縛りを断つ

type 2では,別頁「Excelのヒストグラムの外形をRのそれに似せるためのあれこれ」での考え方をベースとしています。

type2

VBEの起動

綾子

4

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

綾子

5

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

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

コードのコピペ

綾子

6

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

Const binClr As Long = 102 ' bin, bin rangeのグレーの濃度(RGB; 0黒←→255白)
Const binLWgt As Single = 1.5 ' bin の線の太さ(pt; ver.2010は変更不可)
Const axClr As Long = 152 ' 軸のグレーの濃度(RGB; 0黒←→255白)
Const fnDl As String = "Consolas" ' 軸目盛のFont
Const axLr_B As Double = 0.05 ' bin1と軸との距離(range*axLr)
Const axLr_R As Double = 0.07 ' 目盛り線の長さ(range*axLr)

Sub HIST__12common___Preprocess()

' *** ヒストグラムの作成 with Excel VBA|前処理 ver.1.0.0
' *** hitorimarketing.net/tools/vba/code03-hist.html
' *** by hawcas 2017

Dim target As Range ' 選択範囲
Dim vLabel As String ' 変数名
Dim ShtName As String ' シート名

Application.ScreenUpdating = False

ShtName = ActiveSheet.Name
Set target = Selection
If IsNumeric(target.Range("a1")) Then
        vLabel = "無題の変数"
    Else
        vLabel = target.Range("a1").Value
        Set target = target.Range("a2").Resize(RowSize:=target.Rows.Count - 1, ColumnSize:=1)
End If

' 選択内容のチェック
If Err_Checker1(target) = True Then
    Exit Sub
End If

Worksheets.Add
ActiveSheet.Name = "OP-" & ShtName

Cells(1, 1).Value = "シート名"
Cells(2, 1).Value = "変数名"
Cells(3, 1).Value = "データ範囲"

Cells(5, 1).Value = "n"
Cells(6, 1).Value = "MIN"
Cells(7, 1).Value = "MAX"
Cells(8, 1).Value = "MEAN"
Cells(9, 1).Value = "SD"

Cells(11, 1).Value = "▼階級幅の目安"
Cells(12, 1).Value = "Scott"
Cells(13, 1).Value = "Sturges"
Cells(14, 1).Value = "FD"
Cells(15, 1).Value = "平方根"

Cells(1, 4).Value = "▼階級の基本設定"
Cells(2, 4).Value = "最初の階級の下境界"
Cells(3, 4).Value = "階級幅"

With Application.WorksheetFunction
    Cells(1, 2).Value = ShtName
    Cells(2, 2).Value = vLabel
    Cells(3, 2).Value = target.Address

    Cells(5, 2).Value = .Count(target) ' n
    Cells(6, 2).Value = .Min(target) ' min
    Cells(7, 2).Value = .Max(target) ' max
    Cells(8, 2).Value = .Average(target) ' mean
    Cells(9, 2).Value = .StDev(target) ' sd
    
    Cells(12, 2).Value = 3.5 * Cells(9, 2).Value / Cells(5, 2).Value ^ (1 / 3) ' Scott
    Cells(13, 2).Value = (Cells(7, 2).Value - Cells(6, 2).Value) / (1 + (.Log(Cells(5, 2).Value) / .Log(2))) ' Sturges
    Cells(14, 2).Value = 2 * (.Quartile_Inc(target, 3) - .Quartile_Inc(target, 1)) / Cells(5, 2).Value ^ (1 / 3) ' FD
    Cells(15, 2).Value = (Cells(7, 2).Value - Cells(6, 2).Value) / Cells(5, 2).Value ^ (1 / 2) ' square-root

    ' 第1階級の下限と階級幅の決定
    Cells(3, 5).Value = BIN_WIDTH(Cells(12, 2).Value) ' デフォルト値(Scott)
    If CInt(Application.Version) > 14 Then ' バージョンによる調整
        Cells(2, 5).Value = .Floor_Math(Cells(6, 2).Value, Cells(3, 5).Value) ' デフォルト値(Scottによる)
    Else
        Cells(2, 5).Value = .Floor(Cells(6, 2).Value, Cells(3, 5).Value) ' 〃
    End If
End With

Application.ScreenUpdating = True

End Sub

Sub HIST__12common__Main()

' *** ヒストグラムの作成 with Excel VBA|主処理 ver.1.0.0
' *** hitorimarketing.net/tools/vba/code03-hist.html
' *** by hawcas 2017

Application.ScreenUpdating = False

Dim target As Range ' 元データ
Dim targetG_A As Range ' グラフソース
Dim vRange As Double ' レンジ
Dim fMax As Long ' 最大度数
Dim bins As Long ' binの数
Dim tmp
Dim x As Long ' 以下カウンタ
Dim y As Long
Dim i As Long

' シートのチェック
If Err_Checker2 = True Then
    Exit Sub
End If
' 階級幅と下境界のチェック
If Err_Checker4(Range("e3").Value) = True Then ' 階級幅
    Call Err4
    Exit Sub
End If
If Err_Checker4(Range("e2").Value) = True Then ' 境界値
    Call Err5
    Exit Sub
End If
If Range("e2").Value >= Range("b6").Value Then ' 境界値
    Call Err6
    Exit Sub
End If

Set target = Sheets(Range("b1").Value).Range(Range("b3").Value) ' データ範囲を格納
    
Cells(5, 4).Value = "▼度数分布表"
Cells(6, 6).Value = "度数"
Cells(6, 7).Value = "最大度数"

' 度数分布表の作成
x = 4
y = 7
i = 1
fMax = 0
Do
    Select Case i
    Case 1 ' 第1階級下境界
        Cells(y, x).Value = Range("e2").Value

    Case Else ' 第2階級以降の下境界
        tmp = Cells(y - 1, x).Value
        Cells(y, x).Value = tmp + Range("e3").Value
    End Select
        
    Cells(y, x + 1).Value = Cells(y, x).Value + Range("e3").Value ' 上境界
    Cells(y, x + 2).Formula = "=countif('" & Range("b1").Value & "'!" & _
        Range("b3").Value & ",""<=" & Cells(y, x + 1).Value & """)" & _
        "-countif('" & Range("b1").Value & "'!" & _
        Range("b3").Value & ",""<=" & Cells(y, x).Value & """)" ' 式を設置
    If Cells(y, x + 2).Value > fMax Then ' 最大度数の探索
        fMax = Cells(y, x + 2).Value
    End If

    y = y + 1
    i = i + 1
Loop While Cells(y - 1, x + 1).Value < Range("b7").Value
Cells(7, 7).Value = fMax

bins = i - 1 ' binの数
Range(Cells(6, 5).Address, Cells(6, 5).Offset(bins, 2).Address).Select
Set targetG_A = Selection
ActiveSheet.Shapes.AddChart(xlColumnClustered).Select ' 集合縦棒グラフを作成
    
With ActiveChart
    .HasLegend = False ' 凡例除去
    .ChartGroups(1).GapWidth = 0 ' 間隔=0
    .SeriesCollection(1).AxisGroup = 2 ' 柱→2軸
    .SeriesCollection(1).Border.Color = RGB(255, 255, 255) ' 柱の外枠線色
    .SeriesCollection(1).Border.Weight = xlThin ' 柱外枠の太さ
    .SeriesCollection(2).ChartType = xlXYScatter ' 最大度数→散布図へ
    .Axes(xlCategory).MinimumScale = Cells(2, 5).Value ' 軸スケール合わせ
    .Axes(xlCategory).MaximumScale = targetG_A.Cells(1, 1).Offset(bins, 0).Value ' 〃
    .SeriesCollection(2).MarkerStyle = xlMarkerStyleNone ' マーカーを不可視に
    .Axes(xlValue, xlSecondary).TickLabelPosition = xlNone ' 2軸ラベルを不可視に
    .Axes(xlValue, xlSecondary).MajorTickMark = xlNone ' 2軸目盛を不可視に
End With

' 「軸設定」のラベル
With targetG_A.Cells(1, 1)
    .Offset(bins + 2, -1).Value = "▼軸設定"
    .Offset(bins + 3, -1).Value = "Y"
    .Offset(bins + 5, -1).Value = "X"
    .Offset(bins + 3, 0).Value = "最大値"
    .Offset(bins + 4, 0).Value = "目盛間隔"
    .Offset(bins + 5, 0).Value = "目盛間隔"
    .Offset(bins + 6, 0).Value = "開始値"
End With
'MsgBox "合計:" & Application.WorksheetFunction.Sum(Range(Range("F7"), _
    Range("F7").Offset(bins - 1, 0)))

Application.ScreenUpdating = True

End Sub

Sub HIST__12common_AxesSetting()
' type1グラフの軸修正|X,Y両軸の設定

Dim i As Long

Application.ScreenUpdating = False

' シートのチェック
If Err_Checker2 = True Then
    Exit Sub
End If
' グラフのチェック
If Err_Checker3 = True Then
    Exit Sub
End If

i = 0
Do
    i = i + 1
Loop While Range("e7").Offset(i, 0).Value <> ""

If Range("e7").Offset(i + 2, 1).Value <> "" And _
    IsNumeric(Range("e7").Offset(i + 2, 1).Value) = True Then
    With ActiveChart
            .Axes(xlValue).MinimumScale = 0
            .Axes(xlValue).MaximumScale = Range("e7").Offset(i + 2, 1).Value
            .Axes(xlValue, xlSecondary).MinimumScale = 0
            .Axes(xlValue, xlSecondary).MaximumScale = Range("e7").Offset(i + 2, 1).Value
    End With
End If
If Range("e7").Offset(i + 3, 1).Value <> "" And _
    IsNumeric(Range("e7").Offset(i + 3, 1).Value) = True Then
    With ActiveChart
            .Axes(xlValue).MajorUnit = Range("e7").Offset(i + 3, 1).Value
            .Axes(xlValue, xlSecondary).MajorUnit = Range("e7").Offset(i + 3, 1).Value
    End With
End If
If Range("e7").Offset(i + 4, 1).Value <> "" And _
    IsNumeric(Range("e7").Offset(i + 4, 1).Value) = True Then
    With ActiveChart
            .Axes(xlCategory).MajorUnit = Range("e7").Offset(i + 4, 1).Value
    End With
End If

Application.ScreenUpdating = True

End Sub

Sub HIST__type2_Changer()

' *** ヒストグラムの作成 with Excel VBA|type2 Changer ver.1.0.0
' *** hitorimarketing.net/tools/vba/code03-hist.html
' *** by hawcas 2017

Dim target As Range ' 度数分布表
Dim ser_CP As String ' 系列名
Dim ser_X ' X
Dim ser_Y ' Y
Dim Ser_CNT As Long ' 系列のカウンタ
Dim gxRange ' x軸レンジ
Dim gyRange ' y軸レンジ
Dim gyMax As Long ' y軸Max
Dim gyMU As Long ' Y軸目盛間隔
Dim gxMU ' X軸目盛間隔
Dim gxLE ' X軸左端
Dim bins As Long ' 柱の数
Dim digit As Long  ' 階級幅の小数点以下の有効桁
Dim NF As Boolean ' 度数が0かそうでないか判別のためのフラグ
Dim NFx As Long ' 度数0の階級の数
Dim MM As Long ' partsの進行状況
Dim buf
Dim i ' 以下カウンタ
Dim j As Long

Application.ScreenUpdating = False

' シートのチェック
If Err_Checker2 = True Then
    Exit Sub
End If
' グラフのチェック
If Err_Checker3 = True Then
    Exit Sub
End If

Set target = Range("d6").CurrentRegion
Set target = target.Range("a3").Resize(RowSize:=target.Rows.Count - 2, ColumnSize:=3)

Cells(1, 9).Value = "▼parts"
bins = target.Rows.Count

' partsの作成―bin
    i = 1 ' bin no.
    j = 1 ' Row no.
    NFx = 0 ' freq0 bin counter
Do
    NF = False
    If target.Cells(i, 3).Value <> 0 Then
        With Range("i1")
            .Offset(j, 0).Value = target.Cells(i, 1).Value ' 下境界
            .Offset(j, 1).Value = target.Cells(i, 1).Value ' 下境界
            .Offset(j, 2).Value = target.Cells(i, 2).Value ' 上境界
            .Offset(j, 3).Value = target.Cells(i, 2).Value ' 上境界
            .Offset(j + 1, 0).Value = 0
            .Offset(j + 1, 1).Value = target.Cells(i, 3).Value ' 度数
            .Offset(j + 1, 2).Value = target.Cells(i, 3).Value ' 度数
            .Offset(j + 1, 3).Value = 0
        End With
    Else
        NF = True
        NFx = NFx + 1
    End If
    If NF = False Then
        i = i + 1
        j = j + 2
    Else
        i = i + 1
    End If
    MM = j
Loop Until i > bins

' type1からパラメータを読み込み
gyRange = ActiveChart.Axes(xlValue).MaximumScale - ActiveChart.Axes(xlValue).MinimumScale
gxRange = target.Cells(bins, 2).Value - target.Cells(1, 1).Value
With ActiveChart
    gyMax = .Axes(xlValue).MaximumScale
    gyMU = .Axes(xlValue).MajorUnit
    gxMU = .Axes(xlCategory).MajorUnit
End With

If Range("e7").Offset(bins + 5, 1).Value <> "" And _
    IsNumeric(Range("e7").Offset(bins + 5, 1).Value) = True Then
    gxLE = Range("e7").Offset(bins + 5, 1).Value
Else
    gxLE = target.Cells(1, 1).Value
End If

' 集合縦棒を描画
Range(Range("i2"), Range("l3")).Select
ActiveSheet.Shapes.AddChart(xlXYScatterLinesNoMarkers).Select
With ActiveChart
    .SeriesCollection(1).Name = "bin-1"
    .SeriesCollection(1).Border.Color = RGB(binClr, binClr, binClr)
    .HasLegend = False
    If CInt(Application.Version) <= 14 Then ' バージョンによる調整
        .SeriesCollection(1).Format.Line.Weight = 1 'pt, for 2010
    Else
        .SeriesCollection(1).Format.Line.Weight = binLWgt 'pt, for 2013 and later
    End If
End With
Ser_CNT = 2

For i = 0 To ((bins - 1) * 2) - (NFx * 2) - 2 Step 2
    With ActiveChart.SeriesCollection.NewSeries
        .XValues = Range(Range("i1").Offset(i + 3, 0), Range("i1").Offset(i + 3, 3))
        .Values = Range(Range("i1").Offset(i + 4, 0), Range("i1").Offset(i + 4, 3))
        .Name = "bin-" & Ser_CNT
        .Border.Color = RGB(binClr, binClr, binClr)
        If CInt(Application.Version) <= 14 Then ' バージョンによる調整
            .Format.Line.Weight = 1 'pt, for 2010
        Else
            .Format.Line.Weight = binLWgt 'pt, for 2013 and later
        End If
    End With
    Ser_CNT = Ser_CNT + 1
Next

' partsの作成―bin range
With Range("i1")
    .Offset(MM, 0).Value = target.Cells(1, 1).Value ' 第1階級の下境界
    .Offset(MM, 1).Value = target.Cells(bins, 2).Value ' 最後の階級の上境界
    .Offset(MM + 1, 0).Value = 0
    .Offset(MM + 1, 1).Value = 0
End With
With ActiveChart.SeriesCollection.NewSeries
    .XValues = Range(Range("i1").Offset(MM, 0), Range("i1").Offset(MM, 1))
    .Values = Range(Range("i1").Offset(MM + 1, 0), Range("i1").Offset(MM + 1, 1))
    .Name = "bin-range"
    .Border.Color = RGB(102, 102, 102)
    .Format.Line.Weight = 1 'pt
End With
    MM = MM + 2

' partsの作成―yAxis
Ser_CNT = 1
j = ActiveChart.SeriesCollection.Count + 1 ' y軸用obj開始番号
For i = 0 To gyRange / gyMU
    With Range("i1")
        .Offset(MM, 0).Value = target.Cells(1, 1).Value - gxRange * axLr_B
        .Offset(MM, 1).Value = target.Cells(1, 1).Value - gxRange * axLr_R
        .Offset(MM + 1, 0).Value = gyMU * i
        .Offset(MM + 1, 1).Value = gyMU * i
    End With
    With ActiveChart.SeriesCollection.NewSeries
        .XValues = Range(Range("i1").Offset(MM, 0), Range("i1").Offset(MM, 1))
        .Values = Range(Range("i1").Offset(MM + 1, 0), Range("i1").Offset(MM + 1, 1))
        .Name = "yAxis-MU-" & Ser_CNT
        .Border.Color = RGB(axClr, axClr, axClr)
        .Format.Line.Weight = 1 'pt
    End With
    ' データラベルの追加
    With ActiveChart
        .SeriesCollection(j).Select
        .SetElement (msoElementDataLabelLeft)
        .SeriesCollection(j).DataLabels.Select
    End With
    With Selection
        .ShowCategoryName = False
        .ShowValue = True
        .Font.Name = fnDl 'Font
        If CInt(Application.Version) > 14 Then ' バージョンによる調整
            .Format.TextFrame2.MarginRight = 0 ' 右余白0
        End If
    End With
    ActiveChart.SeriesCollection(j).Points(1).HasDataLabel = False ' 右のラベルを不可視に
    Ser_CNT = Ser_CNT + 1
    j = j + 1
    MM = MM + 2
Next

' partsの作成―xAxis
digit = 0
For i = gxLE To target.Cells(bins, 2).Value Step gxMU ' 有効桁を判定
    If InStr(i, ".") > 0 Then
        If digit < Len(i) - InStr(i, ".") Then
        digit = Len(i) - InStr(i, ".")
        End If
    End If
Next
If digit > 0 Then
    buf = "0."
    i = 1
        Do
            buf = buf & "0"
            i = i + 1
        Loop Until i > digit
End If
Ser_CNT = 1
For i = gxLE To target.Cells(bins, 2).Value Step gxMU
    With Range("i1")
        .Offset(MM, 0).Value = i
        .Offset(MM, 1).Value = i
        .Offset(MM + 1, 0).Value = 0 - gyRange * axLr_B
        .Offset(MM + 1, 1).Value = 0 - gyRange * axLr_R
    End With
    With ActiveChart.SeriesCollection.NewSeries
        .XValues = Range(Range("i1").Offset(MM, 0), Range("i1").Offset(MM, 1))
        .Values = Range(Range("i1").Offset(MM + 1, 0), Range("i1").Offset(MM + 1, 1))
        .Name = "xAxis-MU-" & Ser_CNT
        .Border.Color = RGB(axClr, axClr, axClr)
        .Format.Line.Weight = 1 'pt
    End With
    ' データラベルの追加
    With ActiveChart
        .SeriesCollection(j).Select
        .SetElement (msoElementDataLabelBottom)
        .SeriesCollection(j).DataLabels.Select
    End With
    With Selection
        .ShowCategoryName = True
        .ShowValue = False
        .Font.Name = fnDl 'Font
        If digit > 0 Then
            .NumberFormatLocal = buf
        End If
    End With
    Ser_CNT = Ser_CNT + 1
    ActiveChart.SeriesCollection(j).Points(1).HasDataLabel = False ' 上のラベルを不可視に
    j = j + 1
    MM = MM + 2
Next

' partsの作成―yAxis Lines
With Range("i1")
    .Offset(MM + 2, 0).Value = target.Cells(1, 1).Value - gxRange * axLr_B
    .Offset(MM + 2, 1).Value = target.Cells(1, 1).Value - gxRange * axLr_B
    .Offset(MM + 3, 0).Value = 0
    .Offset(MM + 3, 1).Value = gyMax
End With
With ActiveChart.SeriesCollection.NewSeries
    .XValues = Range(Range("i1").Offset(MM + 2, 0), Range("i1").Offset(MM + 2, 1))
    .Values = Range(Range("i1").Offset(MM + 3, 0), Range("i1").Offset(MM + 3, 1))
    .Name = "yAxis-Line"
    .Border.Color = RGB(axClr, axClr, axClr)
    .Format.Line.Weight = 1 'pt
End With

' partsの作成―xAxis Lines
With Range("i1")
    .Offset(MM, 0).Value = gxLE ' 第1階級の下境界 or 任意の開始値
    .Offset(MM, 1).Value = target.Cells(bins, 2).Value ' 最後の階級の上境界
    .Offset(MM + 1, 0).Value = 0 - gyRange * axLr_B
    .Offset(MM + 1, 1).Value = 0 - gyRange * axLr_B
End With
With ActiveChart.SeriesCollection.NewSeries
    .XValues = Range(Range("i1").Offset(MM, 0), Range("i1").Offset(MM, 1))
    .Values = Range(Range("i1").Offset(MM + 1, 0), Range("i1").Offset(MM + 1, 1))
    .Name = "xAxis-Line"
    .Border.Color = RGB(axClr, axClr, axClr)
    .Format.Line.Weight = 1 'pt
End With

' 実際の軸レンジの調整
With ActiveChart
    .Axes(xlCategory).MinimumScale = target.Cells(1, 1).Value - gxRange * (axLr_R + 0.01)
    .Axes(xlCategory).MaximumScale = target.Cells(bins, 2).Value + gxRange / 20
    .Axes(xlValue).MinimumScale = 0 - gyRange * axLr_R
    .Axes(xlValue).MaximumScale = gyMax + gyRange * 1 / 100
    .Axes(xlValue).Select
End With
With Selection
    .Format.Line.Visible = msoFalse
    .TickLabelPosition = xlNone ' 不可視化
End With
    ActiveChart.Axes(xlCategory).Select
With Selection
    .TickLabelPosition = xlNone ' 不可視化
    .Format.Line.Visible = msoFalse
End With
ActiveChart.Axes(xlValue).MajorGridlines.Delete ' 目盛線除去

' 縦横比の調整(おおむね等比に)
With ActiveChart
    .ChartArea.Width = 300
    .ChartArea.Height = 280
    .PlotArea.Select
End With
With Selection
    .Top = 0
    .Left = ActiveChart.ChartArea.Width - .Width
End With

Application.ScreenUpdating = True

End Sub

Sub HIST_12common_AddNormalCurve()
' 正規曲線を加える

Dim bins As Long
Dim i As Long

Application.ScreenUpdating = False

' シートのチェック
If Err_Checker2 = True Then
    Exit Sub
End If
' グラフのチェック
If Err_Checker3 = True Then
    Exit Sub
End If

bins = COUNT_BINS
i = 1
Cells(1, 14).Value = "▼fx"
Do
    Select Case i
    Case 1
        Cells(1, 14).Offset(i, 0).Value = Cells(2, 5).Value ' xの初期値
    Case Else
        Cells(1, 14).Offset(i, 0).Formula = "=" & Cells(1, 14).Offset(i - 1, 0).Address & "+(" & Range("e6").Offset(bins, 0).Address & "-$D$7)/100" ' 2番目以降のx
    End Select
    
    Cells(1, 14).Offset(i, 1).Formula = "=NORM.DIST(" & Cells(1, 14).Offset(i, 0).Address & ",$B$8,$B$9,FALSE)*$B$5*$E$3" ' 確率密度関数
    i = i + 1
Loop While Cells(1, 14).Offset(i - 1, 0).Value < Range("e6").Offset(bins, 0).Value ' x軸レンジ上限まで繰り返し

With ActiveChart.SeriesCollection.NewSeries ' Normal_Curve系列の追加
    .XValues = Range(Range("n1").Offset(1, 0), Range("n1").Offset(i - 1, 0))
    .Values = Range(Range("n1").Offset(1, 1), Range("n1").Offset(i - 1, 1))
    .Name = "Normal_Curve"
    .Border.Color = RGB(binClr, binClr, binClr)
    .Format.Line.Weight = 1 'pt
End With

ActiveChart.SeriesCollection("Normal_Curve").ChartType = xlXYScatterSmoothNoMarkers ' 平滑線化

Application.ScreenUpdating = True

End Sub

Function COUNT_BINS()
' binをカウント

Dim i As Long
i = 0
Do
    i = i + 1
Loop While Range("e7").Offset(i, 0).Value <> ""
COUNT_BINS = i

End Function

Function BIN_WIDTH(h)
' 階級幅を調整する

Dim N As Long
Dim Stp(2) ' 処理過程  step1 to 3
Dim tmp ' 値

Select Case Cells(12, 2).Value
Case Is <= 0
    MsgBox "ERROR"
    Exit Function

Case Is >= 1 ' hが1以上の場合の処理
    N = -1
    Do
        N = N + 1
        Stp(0) = 10 ^ N
        Stp(1) = h / Stp(0)
    Loop Until Stp(1) <= 10
    tmp = Application.WorksheetFunction.MRound(h, Stp(0) * 5)
    If tmp = 0 Then
        tmp = Application.WorksheetFunction.MRound(h, Stp(0) * 1)
    End If

Case Is < 1 ' hが1より小さな場合の処理
    N = -1
    Do
        N = N + 1
        Stp(0) = 10 ^ N
        Stp(1) = 1 / (Stp(0) * 10)
        Stp(2) = h / Stp(1)
    Loop Until Stp(2) >= 1
    tmp = Application.WorksheetFunction.MRound(h, Stp(1) * 5)
    If tmp = 0 Then
        tmp = Application.WorksheetFunction.MRound(h, Stp(1) * 1)
    End If

End Select

BIN_WIDTH = tmp

End Function

Private Sub Err1()
    MsgBox "見出しを除く選択範囲に数値以外が含まれています"
End Sub

Private Sub Err2()
    MsgBox "処理対象のシートがアクティブになっていません"
End Sub

Private Sub Err3()
    MsgBox "アクティブなグラフがありません"
End Sub

Private Sub Err4()
    MsgBox "階級幅に指定されている内容が数値ではありません"
End Sub

Private Sub Err5()
    MsgBox "最初の階級の下境界に指定されている内容が数値ではありません"
End Sub

Private Sub Err6()
    MsgBox "最初の階級の下境界に妥当でない値が設定されています" & vbCrLf & _
        "変数のレンジをカバーするには,この値が最小値より小さな値である必要があります"
End Sub

Function Err_Checker1(myRange As Range) As Boolean
' 選択範囲に数値以外が含まれているか

Dim cc
Err_Checker1 = False

For Each cc In myRange
    If IsNumeric(cc) = False Or cc = "" Then
        Err_Checker1 = True
        Call Err1
    End If
Next

End Function

Function Err_Checker2() As Boolean
' 「OP-」で始まるシートがアクティブか

Err_Checker2 = False
If Left(ActiveSheet.Name, 3) <> "OP-" Then
    Err_Checker2 = True
    Call Err2
End If

End Function

Function Err_Checker3() As Boolean
' グラフがアクティブになっているか

If ActiveChart Is Nothing Then
    Err_Checker3 = True
    Call Err3
Else
    Err_Checker3 = False
End If

End Function

Function Err_Checker4(s) As Boolean
' 数値かどうか

If IsNumeric(s) = False Or _
    s = "" Then
    Err_Checker4 = True
Else
    Err_Checker4 = False
End If

End Function

綾子

7

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

綾子

8

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

以降は一連のマクロの具体的な使い方です。

データ範囲の指定

晴花

9

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

見出しについては,範囲に含めるか否かは問いません。仮に含めない場合,以降のプロセスでは「無題の変数」として扱います。

マクロのアウトライン

晴花

10

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

晴花

11

マクロダイアログが表示されます。「マクロ名」には,下の5つのマクロが表示されているかと思います。

先に見たいずれのtypeを目的とするかにしたがって,必要によりこれら15のマクロを,取捨選択して,あるいはすべて使ってヒストグラムをつくっていくことになります。

晴花

12

どのマクロがどの順番で必要か……については,下のフローチャートによってあらわすことができます。

たとえば,type 1のグラフを付加的な調整を加えずにつくるとしたら,1, 22つのマクロのみを順に適用すればOKであることがわかります。

マクロ実行のフロー図

晴花

13

ただし,例示の必要からここではすべてのマクロを実行していきたいので,必然的に次のパープルのパスを……
すなわち,付加的な調整もすべて経るかたちのtype 2のグラフを選択したいと思います。

type2の場合の経路

マクロの実行

晴花

14

…ということで,

開きっぱなしになっているマクロダイアログの……「マクロ名」に並ぶマクロの中から…最も上のHIST__12common___Preprocessを選択して,実行ボタンをクリックします。

晴花

15

このマクロにより,下のようなあたらしいシートが挿入されます。このシートには,元のシート名の頭に「OP-」を加えた名前が振られます。

このシートでは,

  • 基本統計量
  • 階級幅の目安

が求められます。後者については,

  • スコット
  • スタージェス
  • フリードマン=ダイアコニス
  • 平方根

の各アルゴリズムをすべて通しています。左から4列目,「階級の基本設定」の「階級幅」の値は,このときのスコットをもとにつくっており,これをデフォルトとしています。

もちろん「最初の階級の下境界」「階級幅」とも,デフォルトの値を無視して任意の値に変えてもかまいません。

晴花

16

つづいてマクロダイアログの……「マクロ名」に並ぶマクロの中から…上から2番目のHIST__12common__Mainを選択して,実行ボタンをクリックします。

晴花

17

これによって,シートの上に度数分布表をつくります。

そしてそれをソースとして,下の図のようにtype 1グラフをあわせて描画します。

晴花

18

さて,私がこのヒストグラムを見て,次の2つの点を修正したいと考えたとして話を進めます。

  • [縦軸] 目盛間隔を現状の10から20に変えたい
  • [横軸] 目盛間隔を現状の1から2(階級4つ分)に変えたい

晴花

19

こうした変更に関しては,同じシートの上にある「軸設定」にておこないます。

先の意向を反映するかたちで,下図のように必要な値を指定します。


X の「開始値」は,後段の type 2 でのみ利用できますtype 1作成時は,ここに値が入っていても処理の上では無視します。

晴花

20

type 1グラフをアクティブにした状態から

マクロダイアログを呼び出します。

そして,一連のマクロの中から…上から3番目となるHIST__12common_AxesSettingを選択し,実行ボタンをクリックします。

晴花

21

これによって軸の調整がおこなわれます。

……ただし,この例の場合には,下の図・上段のハイライトの部分が気になるといえば気になるような……そんな思いも持っています。

軸の始点が整数でないので,これより後ろの目盛ももれなくその影響を受けざるをえない状態となっているワケですが……やはり,元データと照らして整数でとった目盛を維持することができたのなら,グラフとしては,その方が格段と読みやすくはあるだろうと思うので,なんとかしたいところではあります。

結論から言えば,これを解決するには次の2つの方法があります。

  • 「最初の階級の下境界」を(この例では)もう1階級分の余裕を持たせ,「0」に変えてつくり直す
  • 実際の軸の始点から表示上の始点を(この例では)1階級分後ろにずらす。つまり,軸を「1」から表示するようにする(下図・下段のパープルの線)

横軸の始点が0.5

横軸の始点が1

晴花

22

2つの解決法のうち,後者はtype 2のみで適用できます。

この設定をシートにおいて入力すると,下の図のようになります。

晴花

23

type 1グラフをアクティブにした状態から

マクロダイアログを呼び出します。

そして,一連のマクロの中の…上から4番目となるHIST__type2_Changerを選択し,実行ボタンをクリックします。

晴花

24

これによりtype 1グラフの書式情報を引くかたちで,同じシートの上にtype 2グラフを出力します。

晴花

25

ここでtype 2のヒストグラムを正規曲線と照らしたいとして,それをグラフ上に重ねてみます。

type 2グラフをアクティブにした状態から

マクロダイアログを呼び出します。

そして,一連のマクロの中のいちばん下HIST_12common_AddNormalCurveを選択し,実行ボタンをクリックします。

晴花

26

これにより,正規曲線が加えられます。

パラメータは,シートの上の

  • MEAN
  • SD

を,スケールの調整には,同じくシートの上の

  • n

を利用しています。

したがってそれらを直接変更すれば,グラフの上に重ねられた曲線も追従します。

その他,グラフタイトルや軸ラベルの追加,あるいはグラフエリアやプロットエリアのサイズの変更などいくらかの書式設定や調整を任意におこなって,ヒストグラムの完成です。

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

LastUpdate

2017.1.2

.
このページの先頭へ