Excel VBAで一般的なレポート向けのヒストグラムを出力する実行プログラムを作ってみた３

前回、分析ツールで作成したヒストグラムも、一般的なレポートに載せるのにはカッコ悪過ぎ、というお話をさせていただきました。

エクセルExcel標準の機能で、手早くかっこいいヒストグラムを作るのは無理なようですので、これはＶＢＡで作るしかない！　と思ったら・・・

なんと、既にありました。

やられたー。

こちら、前回もお世話になったウェブサイト、BDAstyleの管理人様が開設されているメインサイトになります。詳細な解説に加えて、マクロのソースまで公開されていて、もう私の出る幕ないですね。

と思ってさっそく使わせていただいたら、なるほど確かに便利なのですが、最終形がＲライクなグラフ書式を指向されていて、私の目的とはちょっと違います。

また、こまかく設定を変えたりできる分、サブプロシージャが５つに別れていたりして、誠に恐縮ながら、正直ちょっと面倒です。

そこで今回は、上記サイト「ひとりマーケティングのためのデータ分析」様のソースコードを、私の目的に合わせてカスタマイズさせていただくことにしました。

改変のポイントは以下の３つです。

• （ユーザーが）簡単、手間なし
• 一般的なレポートにササッとコピペできるようなシンプルな出力
• 左閉半開区間（◯以上□未満）にする

で、カスタムしたコードがこちら。

Sub HISTOGRAM()
    
    Dim Target As Range
    Dim Tmp(1 To 3)
    Dim i

    Application.ScreenUpdating = False
    
    Set Target = Selection ' データ範囲を格納
    
    With WorksheetFunction
        Tmp(1) = BIN_WIDTH((.Max(Target) - .Min(Target)) / _
            .RoundUp(1 + .Log(Target.Rows.Count, 2), 0)) 'スタージェスの公式
        Tmp(2) = .Floor(.Min(Target), Tmp(1)) - Tmp(1)
        Tmp(3) = .Ceiling(.Max(Target), Tmp(1)) + Tmp(1)
    End With
    
    Worksheets.Add

    ' 度数分布表の作成
    Cells(1, 1).Value = "▼度数分布表"
    Cells(2, 1).Value = "区間（下境界≦X＜上境界）"
    Cells(2, 3).Value = "度数"
    Cells(2, 4).Value = "最大度数"
    
    With WorksheetFunction
        For i = 0 To (Tmp(3) - Tmp(2)) / Tmp(1) - 1
            Cells(i + 3, 1).Value = Tmp(2) + Tmp(1) * i
            Cells(i + 3, 2).Value = Tmp(2) + Tmp(1) * (i + 1)
            Cells(i + 3, 3) = .CountIfs(Target, ">=" & Cells(i + 3, 1).Value, _
                Target, "<" & Cells(i + 3, 2).Value)
        Next
        Cells(3, 4).Value = .Max(Range(Cells(3, 3), Cells(i + 3, 3)))
    End With
    
    ' 度数分布表の書式設定
    With Range("A2:B2")
        .Merge
        .HorizontalAlignment = xlCenter
        .ShrinkToFit = True
    End With
    Range("C2:D2").HorizontalAlignment = xlCenter
    Range("D2:D3").Borders.LineStyle = True
    Range(Cells(2, 1), Cells(i + 2, 3)).Borders.LineStyle = True
    Range(Cells(3, 1), Cells(i + 2, 2)).Borders(xlInsideVertical).LineStyle = False
    With Range(Cells(3, 1), Cells(i + 2, 1))
        .HorizontalAlignment = xlRight
        .IndentLevel = 1
    End With
    With Range(Cells(3, 2), Cells(i + 2, 2))
        .NumberFormatLocal = """～　""0"
        .HorizontalAlignment = xlLeft
    End With
    ActiveWindow.DisplayGridlines = False
    
    ' グラフ作成
    Range(Cells(2, 3), Cells(i + 2, 4)).Select
    ActiveSheet.Shapes.AddChart(xlColumnClustered).Select ' 集合縦棒グラフを作成
        
    With ActiveChart
        .HasLegend = False                      ' 凡例除去
        .ChartGroups(1).GapWidth = 0            ' 間隔=0
        With .SeriesCollection(1)
            .AxisGroup = 2                      ' 柱→2軸
            .Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent3 ' 柱の色→グレー
            .Border.Color = vbWhite             ' 柱の外枠線色→白
            .Border.Weight = xlThin             ' 柱外枠の太さ
        End With
        With .SeriesCollection(2)
            .ChartType = xlXYScatter            ' 最大度数→散布図へ
            .MarkerStyle = xlMarkerStyleNone    ' マーカーを不可視に
        End With
        With .Axes(xlCategory)
            .MinimumScale = Tmp(2)              ' 軸スケール合わせ（最小値）
            .MaximumScale = Tmp(3)              ' 軸スケール合わせ（最大値）
            .MajorUnit = Tmp(1)                 ' 軸スケール合わせ（目盛り）
            .CrossesAt = Tmp(2)                 ' 軸スケール合わせ（交点）
        End With
        With .Axes(xlValue, xlSecondary)
            .TickLabelPosition = xlNone         ' 2軸ラベルを不可視に
            .MajorTickMark = xlNone             ' 2軸目盛を不可視に
        End With
        .Parent.Top = Range("F2").Top           ' 位置調整（上端）
        .Parent.Left = Range("F2").Left         ' 位置調整（左端）
    End With
    Range("F1").Value = "▼ヒストグラム"
    
    Application.ScreenUpdating = True

End Sub

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

    Dim N As Long
    Dim Stp(2) ' 処理過程  step1 to 3
    Dim Tmp ' 値
    
    Select Case h
    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

サブプロシージャHISTOGRAM() は、コードはあまり原形をとどめていませんが、キモの部分の設計思想は、完全にオリジナルを踏襲しています。細かい違いを説明すると、

1. 階級数はスタージェスの公式で求めました。
   .RoundUp(1 + .Log(Target.Rows.Count, 2), 0)
   Log関数はワークシート関数を使わないとエラーになるので注意です。*1
   
   
2. 軸側（下側）にスペースを空けるのはオリジナルと同じですが、左閉半開でも集計漏れがないようにするため、上側にも階級を一つ足しています。*2
   Tmp(3) = .Ceiling(.Max(Target), Tmp(1)) + Tmp(1)
   
   
3. オリジナルは、度数のセルに右閉半開の数式を入力していますが、こちらは左閉半開の計算結果（値）を入れています。
   Cells(i + 3, 3) = .CountIfs(Target, ">=" & Cells(i + 3, 1).Value, _
   Target, "<" & Cells(i + 3, 2).Value)
   
   
4. 度数分布表の書式設定を気張りました。
5. 柱の色をグレーにしました。
6. 横軸の目盛りを階級幅に合わせました。.MajorUnit = Tmp(1)
   
7. 横軸の交点を最小値に合わせました。.CrossesAt = Tmp(2) *3
8. グラフの位置合わせをしました。
   .Parent.Top = Range("F2").Top　.Parent.Left = Range("F2").Left

ファンクションプロシージャBIN_WIDTHは、１箇所だけ、Select Case 句の Cells(12, 2).Value を h に修正し、それ以外はオリジナルをそのまま使わせていただきました。

使い方は、オリジナルと同じです。

データ範囲を予め選択しておいて［マクロ］→［HISTOGRAM］→実行

ただし、オリジナルと違って、操作はこれだけです。
で、結果がこちら。

いかがでしょう。ワタシ的には大満足なんですが。

「ひとりマーケティングのためのデータ分析」のhawcas様、誠にありがとうございました。

*1:VBAのLog関数は、ワークシート関数と違って引数に底がありません。VBAのLog関数は、eを底とする自然対数を返します。

*2:観測に最終区間の下側境界値があれば最終区間にも柱が立ちますが、なければ空きスペースになります。

*3:最小値がマイナスのときに交点がズレなくなります。