HOME TOOLS

2023/7/10

イントロダクション

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

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

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

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

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

免責事項:

  • 掲載のコードは一例として提示しています。諸般のデータに対応するものでも，すべての環境で正常に動作することを保証するものでもありません。
  • ［動作確認環境］
    • Windows 7 32bit ServicePack 1　/　Excel 2010, 2013(32bit版)
    • Windows 8.1 64bit　/　Excel 2010, 2013, 2016(32bit版)
    • Windows 10 64bit　/　Excel 2010, 2013, 2016(32bit版)
  • このコードおよびマクロを利用されたことにより生じた損害，トラブル等につきまして管理者は一切の責任を負いません。

お願い:

  • マクロを利用される場合，万一に備え重要なデータのバックアップをおこなったうえで，事前にテストデータを使って動作を十分に検証されることをおすすめします。

以下，Excel 2016 を使ったヒストグラム作成マクロの導入の仕方，および利用の仕方に関する解説です(その他バージョンであっても2010以降であれば同様の手続きで利用できます)。

綾子

元データと成果物

元のデータです。

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

  • [n] 300
  • [x bar] 4.982
  • [sd(n-1)] 1.030
元データ・ヒストグラム

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

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

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

  • 横軸に境界値をあてがう
  • 横軸の目盛間隔を任意で決める(複数の階級をまたいで間隔をとる)

構造的に準拠している“つくり方”。
type1

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

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

  • 柱と縦横の軸線とに間隙を挟む
  • 横軸のラベルについて，書式設定上の始点に縛られない配置が出来るようにする(たとえば，実直に0.5から1.5,2.5,とラベルを並べるより，1から目盛りをとって2,3,とした方がはるかに読みやすい)。

構造的に準拠している“つくり方”。
type2

VBEの起動

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

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

メニューの挿入から標準モジュールをクリックすると，エディタにコードウインドウが表示されます。

コードのコピペ

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

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｜前処理 b180218c
' *** hitorimarketing.net/tools/vba/histogram-macro.html
' *** by hawcas 2017, 2018

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

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）
    Tmp = .Floor(Cells(6, 2).Value, Cells(3, 5).Value) ' デフォルト値（Scottによる）
    If Cells(6, 2).Value <> Tmp Then
        Cells(2, 5).Value = Tmp
    Else
        Cells(2, 5).Value = Tmp - Cells(3, 5).Value ' min = h のときの第1階級下限の修正
    End If
End With

Application.ScreenUpdating = True

End Sub

Sub HIST__12common__Main()

' *** ヒストグラムの作成 with Excel VBA｜主処理 b180218c
' *** hitorimarketing.net/tools/vba/histogram-macro.html
' *** by hawcas 2017, 2018

Application.ScreenUpdating = False

Dim targetG_A As Range ' グラフのソース(柱のみ)
Dim vRange As Double ' レンジ
Dim fMax As Long ' 最大度数
Dim bins As Long ' binの数
Dim Sht As Worksheet
Dim Ser As Series  ' 追加する系列
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
  
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, 1).Address).Select
Set targetG_A = Selection
Set Sht = ActiveSheet
Sht.Shapes.AddChart(xlColumnClustered).Select ' 集合縦棒グラフを作成
Set Ser = Sht.ChartObjects(1).Chart.SeriesCollection.Add(Range(Cells(6, 5).Offset(1, 2), _
    Cells(6, 5).Offset(bins, 2)))  ' 系列の追加
Ser.Name = Cells(6, 5).Offset(0, 2).Value ' 系列名
   
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(xlValue).MinimumScale = 0 ' 第1縦軸の最小値を明示的に0に(2値の場合の不具合への対処)
    .Axes(xlValue, xlSecondary).MinimumScale = 0 ' 第2縦軸の最小値を明示的に0に(2値の場合の不具合への対処)
    .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

Application.ScreenUpdating = True

End Sub

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

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 b170102
' *** hitorimarketing.net/tools/vba/histogram-macro.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()
' 正規曲線を加える b170102

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

Private 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

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

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

TryVal = Array(5, 2, 1) ' Mround, Ceiling の基準値に掛けるウエイト

With Application.WorksheetFunction
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
    
    N = 0
    Do
        If N < 2 Then
            Tmp = .MRound(h, Stp(0) * TryVal(N))
        Else
            Tmp = .Ceiling(h, Stp(0) * TryVal(N))
        End If
        N = N + 1
    Loop Until Tmp <> 0

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
    
    N = 0
    Do
        If N < 2 Then
            Tmp = .MRound(h, Stp(1) * TryVal(N))
        Else
            Tmp = .Ceiling(h, Stp(1) * TryVal(N))
        End If
        N = N + 1
    Loop Until Tmp <> 0
    
End Select
End With

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

Private 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

Private 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

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

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

End Function

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

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

End Function

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

コードが導入出来たので，VBEを閉じます。

では，ここからマクロの具体的な使い方です。

晴花

データ範囲の指定

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

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

マクロのアウトライン

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

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

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

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

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

マクロ実行のフロー図

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

type2の場合の経路

マクロの実行

ということで，

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

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

このシートでは，

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

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

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

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

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

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

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

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

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

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

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

先の意向を反映させたいので，下図のように必要な値を指定します。


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

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

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

そして，一連のマクロの中から上より3番目のHIST__12common_AxesSettingを選択し，実行ボタンをクリックします。

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

ただし，このテストデータの場合には，下の図・上段のハイライトの部分が気になるといえば気になるようなそんな感情があります。

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

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

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

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

「軸を1から表示する」意向をシートに反映させると，下の図のようになります。

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

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

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

これによりtype 1グラフの書式データを参照しつつ，同じシートの上にtype 2グラフがアウトプットされます。

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

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

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

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

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

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

  • MEAN
  • SD

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

  • n

を利用しています。

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

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