Excelには分析ツールでヒストグラムを作る機能がありますが、それは数値データを対象にしています。日付データや文字列を対象にヒストグラムを作ることはできません。
例えば、年月日のデータリストがあったとして、それが年ごと、月ごとにどうなっているのかを見たり、文字情報のリストがあって同じものがどれぐらいあるのかなどは、いったん何らかの処理をしてからでないとヒストグラムにはできません。そういう処理の後、さらに区間の設定をして、分析ツールでヒストグラムを作るというのは、非常に面倒です。ヒストグラムを作る作業に追われて、本来の知りたいことを調べるまでにとても時間がかかります。
そこで、そういう処理をまとめて全部やってくれるマクロを作りました。
ここでは、
数値データから作るヒストグラムを「ヒストグラム」、
日付で作るヒストグラムを「日付ヒストグラム」、
文字情報で作るヒストグラムを「個数ヒストグラム」と
呼んでいます。
機能は
１．Excelのシート上のセルを選択し、マクロ「ヒストグラムタイプを選んで作成する」を起動すると、数秒でヒストグラムを作ります。
２．セルの選択は１セルで、そのセルを含む１列の上下につながっている列データを対象にします。
３．データの内容を見て、数値データなら普通のヒストグラムを、日付なら日付ヒストグラムを、それ以外は個数ヒストグラムを作成します。
４．日付ヒストグラムでは、適正な区間数になるように、年の区間、月の区間、日の区間のどれにするかをマクロが決めます。変更することも可能です。
５．個数ヒストグラムでは、個数かパーセントかのどちらでグラフにするか、パレート図のように多い順に並べるか、名前順にするか、マクロが見つけた順でグラフにするかを選べます。
６．普通のヒストグラムでは、区間数の数が適正になるようにマクロが決めます。変更もできます。決め方は、平方根選択を基準にしていますが、データの分布が正規分布から外れる時（尖りが大きい時）は１０％、９０％のパーセンタイル値を利用しています。
７．データをシートに書かずにグラフを作ります。データを見たい場合は、グラフ作成の途中でシートに書き出すように変更してください。
いつものとおり、きれいなコードではありません。すいません。
コードが長いので一つの記事に入りませんでした。
ヒストグラムを作成するVBAマクロ その２の後半 普通、日付、個数のヒストグラム
に続きがあります。
Sub ヒストグラムタイプを選んで作成する()
Dim vcell As Range, vRange As Range
Dim icntNum As Long, icntDat As Long, icntStr As Long
icntNum = 0: icntDat = 0: icntStr = 0
Set vRange = Selection
For Each vcell In vRange
If IsNumeric(vcell) = True Then
icntNum = icntNum + 1
End If
If IsDate(vcell) = True Then
icntDat = icntDat + 1
End If
If Vartype(vcell) = vbString Then
icntStr = icntStr + 1
End If
Next vcell
'データの取得と区分のカウント
If icntNum > 0.5 * vRange.Count Then '選択範囲の50％以上が数値ならヒストグラム、違えば個数ヒストグラム
ヒストグラム作成
ElseIf icntDat > 0.5 * vRange.Count Then
日付ヒストグラム作成
Else
個数ヒストグラム作成
End If
Set vRange = Nothing
End Sub
Sub 日付ヒストグラム作成()
Dim SRange As Variant, cl As Variant
Dim xdata() As Double, xUnit As String 'データ、日付単位
Dim xCount() As Long, xRank() As Double 'ヒストグラム区間個数、区間値
Dim i As Long, imax As Long '区間割り振り用変数
Dim xmax2 As Double, xmin2 As Double 'ヒストグラム最大最小
Dim ik As Long, xstep As Double '区間数、区間幅
Dim xmax As Double, xmin As Double 'Raw最大最小
Dim xave As Double, xsum As Double, xcnt As Long, xstd As Double
Dim xQ10 As Double, xQ25 As Double, xQ50 As Double, xQ75 As Double, xQ90 As Double
Dim xRange As Double, xHizumi As Double, xTogari As Double
Dim strtemp As String, strmsg As String, xbuf As Variant, iflg As Integer
Dim objChart As Object, chartTtl As String, xStr As Variant, xTitle As String
Dim ixdata As Long
If ActiveCell.Row > 1 Then '先頭行がアクティブの時に一つ下をアクティブにする
If ActiveCell.Offset(-1, 0).Value = "" Then
ActiveCell.Offset(1, 0).Select
End If
End If
SRange = Range(ActiveCell.End(xlUp), ActiveCell.End(xlDown))
ReDim xdata(UBound(SRange, 1) * UBound(SRange, 2))
xTitle = ActiveCell.End(xlUp).Value
i = 0
For Each cl In SRange
If IsDate(cl) = True Then
xdata(i) = CDbl(DateValue(cl))
i = i + 1
End If
Next cl
If i = 0 Then
MsgBox "日付のセルを選択してから実行してください。"
Exit Sub
End If
ReDim Preserve xdata(i - 1)
'***ヒストグラムデータの作成***
xUnit = "D"
Do
With WorksheetFunction
xmax = .max(xdata)
xmin = .Min(xdata)
xcnt = .Count(xdata)
xsum = .sum(xdata)
xave = .Average(xdata)
xstd = .StDevP(xdata)
xQ25 = .Quartile(xdata, 1)
xQ50 = .Quartile(xdata, 2)
xQ75 = .Quartile(xdata, 3)
xQ10 = Percentile(xdata, 10)
xQ90 = Percentile(xdata, 90)
xHizumi = .Skew(xdata)
xTogari = .Kurt(xdata)
End With
If xTogari > 1# Then '分布が尖っている場合、10%-90%の範囲に設定
xmax2 = xQ90
xmin2 = xQ10
Else
xmax2 = xmax
xmin2 = xmin
End If
xRange = xmax2 - xmin2
ik = 1 + Int(Sqr(xcnt)) '平方根選択
xstep = xRange / ik '区間幅
Select Case xUnit
Case "D", "Y"
xstep = WorksheetFunction.RoundUp(xstep, 0) '日と年は小数以下はなしで日単位
Case "M"
xstep = Round(xstep, 3) '月は小数以下あり
End Select
ik = xRange / xstep '区間数
If xUnit = "D" Then
If xstep >= 365 Then
xUnit = "Y"
xdata = exchDateData(xdata, xUnit)
ElseIf xstep >= 28 Then
xUnit = "M"
xdata = exchDateData(xdata, xUnit)
Else
Exit Do
End If
Else
Exit Do
End If
Loop
If xstep = 0 Then xstep = 1
Select Case xUnit
Case "D"
strmsg = "m = " & CDate(Round(xave, 0)) & vbTab & "sd = " & Round(xstd, 2) & vbTab & "n = " & xcnt & vbCrLf
strmsg = strmsg & "min = " & CDate(xmin) & vbTab & "max = " & CDate(xmax) & vbCrLf
strmsg = strmsg & "Q10/25/50/75/90 = " & CDate(xQ10) & " / " & CDate(xQ25) & " / " & CDate(xQ50) & " / " & CDate(xQ75) & " / " & CDate(xQ90) & vbCrLf
strmsg = strmsg & "歪み = " & Round(xHizumi, 1) & vbTab & "尖り = " & Round(xTogari, 1) & vbCrLf
strmsg = strmsg & "step = " & xstep & vbTab & "k = " & ik & vbTab & "step単位 = " & xUnit
strtemp = CDate(xmin2) & "," & CDate(xmax2) & "," & xstep 'デフォルト
Case "M"
strmsg = "m = " & makeYMstr(xave) & vbTab & "sd = " & makeYMstr(xstd) & vbTab & "n = " & xcnt & vbCrLf
strmsg = strmsg & "min = " & makeYMstr(xmin) & vbTab & "max = " & makeYMstr(xmax) & vbCrLf
strmsg = strmsg & "Q10/25/50/75/90 = " & makeYMstr(xQ10) & " / " & makeYMstr(xQ25) & " / " & makeYMstr(xQ50) & " / " & makeYMstr(xQ75) & " / " & makeYMstr(xQ90) & vbCrLf
strmsg = strmsg & "歪み = " & Round(xHizumi, 1) & vbTab & "尖り = " & Round(xTogari, 1) & vbCrLf
strmsg = strmsg & "step = " & xstep & vbTab & "k = " & ik & vbTab & "step単位 = " & xUnit
strtemp = makeYMstr(xmin2) & "," & makeYMstr(xmax2) & "," & makeYMstr(xstep) 'デフォルト
Case "Y"
strmsg = "m = " & Round(xave, 1) & vbTab & "sd = " & Round(xstd, 2) & vbTab & "n = " & xcnt & vbCrLf
strmsg = strmsg & "min = " & xmin & vbTab & "max = " & xmax & vbCrLf
strmsg = strmsg & "Q10/25/50/75/90 = " & Round(xQ10, 1) & " / " & Round(xQ25, 1) & " / " & Round(xQ50, 1) & " / " & Round(xQ75, 1) & " / " & Round(xQ90, 1) & vbCrLf
strmsg = strmsg & "歪み = " & Round(xHizumi, 1) & vbTab & "尖り = " & Round(xTogari, 1) & vbCrLf
strmsg = strmsg & "step = " & xstep & vbTab & "k = " & ik & vbTab & "step単位 = " & xUnit
strtemp = xmin2 & "," & xmax2 & "," & xstep 'デフォルト
Case Else
MsgBox "ステップの年月日の単位文字YMDが不正です。:" & xUnit
Exit Sub
End Select
strtemp = InputBox("開始値 終了値 ステップ幅を入力してください。" & vbCrLf & strmsg, "区分の設定:日付ヒストグラム", strtemp)
If strtemp = "" Then Exit Sub
xbuf = Split(strtemp, ",") 'xbuf(0,1,2)=xmin,xmax,xstep
'区分数、ランク値を設定
Select Case xUnit
Case "D"
imax = (CDbl(DateValue(xbuf(1))) - CDbl(DateValue(xbuf(0)))) / xbuf(2) + 1
ReDim xRank(imax), xCount(imax), xStr(imax)
For i = 1 To imax
xRank(i) = CDbl(DateValue(xbuf(0))) + (i - 1) * xbuf(2) '小さい順のランク
Next i
Case "M"
imax = (makeYMnum(xbuf(1)) - makeYMnum(xbuf(0))) / makeYMnum(xbuf(2)) + 1
ReDim xRank(imax), xCount(imax), xStr(imax)
For i = 1 To imax
xRank(i) = makeYMnum(xbuf(0)) + (i - 1) * makeYMnum(xbuf(2)) '小さい順のランク
Next i
Case "Y"
imax = (CDbl(xbuf(1)) - CDbl(xbuf(0))) / xbuf(2) + 1
ReDim xRank(imax), xCount(imax), xStr(imax)
For i = 1 To imax
xRank(i) = CDbl(xbuf(0)) + (i - 1) * xbuf(2) '小さい順のランク
Next i
End Select
'データのランクへのカウント
For ixdata = 0 To UBound(xdata)
iflg = 0
For i = 1 To UBound(xRank)
If xdata(ixdata) < xRank(i) Then '小さいランク値から順に調べて、それより小さい時にその下のランクにカウント
xCount(i - 1) = xCount(i - 1) + 1
iflg = 1
Exit For
End If
Next i
If iflg = 0 Then 'カウントされないときは最高値にカウントする
i = UBound(xRank)
xCount(i) = xCount(i) + 1
End If
Next ixdata
'***ヒストグラム図の作成***
Select Case xUnit
Case "D"
xStr(0) = "～" & CDate(xRank(1))
For i = 1 To imax
xStr(i) = CDate(xRank(i)) & "～"
Next i
chartTtl = xTitle & " min=" & CDate(xmin) & " max=" & CDate(xmax) & _
" mean=" & CDate(xave) & " n=" & xcnt & " cond=" & strtemp
Case "M"
xStr(0) = "～" & makeYMstr(xRank(1))
For i = 1 To imax
xStr(i) = makeYMstr(xRank(i)) & "～"
Next i
chartTtl = xTitle & " min=" & makeYMstr(xmin) & " max=" & makeYMstr(xmax) & _
" mean=" & makeYMstr(xave) & " n=" & xcnt & " cond=" & strtemp
Case "Y"
xStr(0) = "～" & xRank(1)
For i = 1 To imax
xStr(i) = xRank(i) & "～"
Next i
chartTtl = xTitle & " min=" & xmin & " max=" & xmax & _
" mean=" & Round(xave, 1) & " n=" & xcnt & " cond=" & strtemp
End Select
Set objChart = plotHistogram(xStr, xCount, , , chartTtl) ', ActiveCell)
Call moveChartPosVisibleRange(objChart)
Set objChart = Nothing
End Sub
Sub ヒストグラム作成()
Dim xCount() As Long, xRank() As Double
Dim i As Long, imax As Long, ix As Long
Dim xmax As Double, xmin As Double, xstep As Double
Dim xmax2 As Double, xmin2 As Double
Dim xstepSQR As Double ', xstepStu As Double, xstepSco As Double, xstepFre As Double
Dim ikSQR As Long ', ikStu As Long, ikSco As Long, ikFre As Long
Dim xave As Double, xsum As Double, xcnt As Long, xstd As Double
Dim xQ10 As Double, xQ25 As Double, xQ50 As Double, xQ75 As Double, xQ90 As Double
Dim xRange As Double
Dim xHizumi As Double, xTogari As Double
Dim iy As Long, iyS As Long, iyE As Long
Dim strtemp As String, strmsg As String, xbuf As Variant, iflg As Integer
Dim ACell As Range, xdata() As Double ', DRange As Range, DCell As Range
Dim objChart As Object, chartTtl As String, xStr As Variant
Dim vRange As Variant, cl As Variant
'データの取得と区分のカウント
Set ACell = ActiveCell
ix = ACell.Column
iyS = ACell.End(xlUp).Row
iyE = ACell.End(xlDown).Row
vRange = Range(ACell.End(xlUp), ACell.End(xlDown))
'***ヒストグラムデータの作成***
With WorksheetFunction
xcnt = .Count(vRange)
ReDim xdata(xcnt) 'パーセンタイル用に1次元配列にする
i = 0
For Each cl In vRange
If IsNumeric(cl) = True Then
xdata(i) = Val(cl)
i = i + 1
End If
Next cl
xmax = .max(vRange)
xmin = .Min(vRange)
xsum = .sum(vRange)
xave = .Average(vRange)
xstd = .StDevP(vRange)
xQ25 = .Quartile(vRange, 1)
xQ50 = .Quartile(vRange, 2)
xQ75 = .Quartile(vRange, 3)
xQ10 = Percentile(xdata, 10)
xQ90 = Percentile(xdata, 90)
xHizumi = .Skew(vRange)
xTogari = .Kurt(vRange)
End With
If xmax = xmin Or xcnt = 0 Then
MsgBox "数値のセルを選択してから実行してください。" & " min=" & CStr(xmin) & " max=" & CStr(xmax)
Exit Sub
End If
If xTogari > 1# Then '分布が尖っている場合、10%-90%の範囲に設定
xmax2 = xQ90
xmin2 = xQ10
Else
xmax2 = xmax
xmin2 = xmin
End If
xRange = xmax2 - xmin2
ikSQR = 1 + Int(Sqr(xcnt)) '平方根選択
xstepSQR = xRange / ikSQR
xstepSQR = RoundN(xstepSQR, 1, 1)
ikSQR = xRange / xstepSQR
xstep = xstepSQR '取りあえず平方根
If xstep = 0 Then xstep = 1
'最終調整
xmax2 = RoundN(xmax2, 2, 1)
xmin2 = RoundN(xmin2, 2, -1)
xmin2 = xstep * Round(xmin2 / xstep, 0) '区間幅xstepの整数倍に合わせる
xRange = xmax2 - xmin2
ikSQR = xRange / xstepSQR
strmsg = "m = " & RoundN(xave, 5) & vbTab & "sd = " & RoundN(xstd, 5) & vbTab & "n = " & xcnt & vbCrLf & _
"min = " & RoundN(xmin, 5) & vbTab & "max = " & RoundN(xmax, 5) & vbCrLf & _
"Q10/25/50/75/90 = " & RoundN(xQ10, 3) & "/" & RoundN(xQ25, 3) & "/" & RoundN(xQ50, 3) & "/" & RoundN(xQ75, 3) & "/" & RoundN(xQ90, 3) & vbCrLf & _
"歪み = " & Round(xHizumi, 2) & vbTab & "尖り = " & Round(xTogari, 2) & vbCrLf & _
"step = " & xstepSQR & vbTab & "k = " & ikSQR
strtemp = CStr(xmin2) & "," & CStr(xmax2) & "," & CStr(xstep) 'デフォルト
strtemp = InputBox("開始値 終了値 ステップ幅を入力してください。" & vbCrLf & _
strmsg, "区分の設定:ヒストグラム", strtemp)
If strtemp = "" Then Exit Sub
strtemp = Replace(strtemp, " ", ",")
strtemp = Replace(strtemp, " ", ",")
xbuf = Split(strtemp, ",") 'xbuf(0,1,2)=xmin,xmax,xstep
'区分数、ランク値を設定
imax = (xbuf(1) - xbuf(0)) / xbuf(2) + 1
ReDim xRank(imax), xCount(imax), xStr(imax)
For i = 1 To imax
xRank(i) = xbuf(0) + (i - 1) * xbuf(2) '小さい順のランク
Next i
'データのランクへのカウント
For Each cl In vRange
If IsNumeric(cl) = True Then '数値の時だけ処理する
iflg = 0
For i = 1 To UBound(xRank)
If cl < xRank(i) Then '小さいランク値から順に調べて、それより小さい時にその下のランクにカウント
xCount(i - 1) = xCount(i - 1) + 1
iflg = 1
Exit For
End If
Next i
If iflg = 0 Then 'カウントされないときは最高値にカウントする
i = UBound(xRank)
xCount(i) = xCount(i) + 1
End If
End If
Next cl
'***ヒストグラム図の作成***
xStr(0) = "～" & xRank(1)
For i = 1 To imax
xStr(i) = xRank(i) & "～"
Next i
chartTtl = Cells(iyS, ix) & " min=" & CStr(RoundN(xmin, 5)) & " max=" & CStr(RoundN(xmax, 5)) & _
" mean=" & CStr(RoundN(xsum / xcnt, 5)) & " n=" & xcnt & " cond=" & strtemp
Set objChart = plotHistogram(xStr, xCount, , , chartTtl) ', ACell.Offset(1, 0))
Call moveChartPosVisibleRange(objChart)
ACell.Select
Set objChart = Nothing
Set ACell = Nothing
End Sub
Sub 個数ヒストグラム作成()
Dim xCount() As Variant, xRank() As Variant
Dim ixS As Long, ixE As Long 'ix As Long,
Dim iyS As Long, iyE As Long
Dim imax As Long, i As Long, iflg As Long, icnt As Long
Dim vtemp As Variant, vRng As Variant, vcell As Variant
Dim ttl As String
Dim iflgSum As Long, iflgSort As Long ', xsum As Double
Dim ACell As Range
Dim objChart As Object, chartTtl As String ', xStr As Variant
'データの取得と区分のカウント
Set ACell = Selection
ixS = ACell(1).Column '選択範囲の最初のセル
ixE = ACell(ACell.Count).Column '選択範囲の最後のセル
iyS = ACell(1).End(xlUp).Row
iyE = ACell(ACell.Count).End(xlDown).Row
vtemp = MsgBox("先頭行 「" & Cells(iyS, ixS) & "」 はタイトルですか？ ", vbYesNo)
If vtemp = vbYes Then
ttl = Cells(iyS, ixS)
iyS = iyS + 1
Else
ttl = CStr(InputBox("タイトルは何ですか？", , "項目名"))
End If
vtemp = MsgBox("件数で集計しますか？ はい(Y)" & vbCrLf & _
"％ で集計しますか？ いいえ(N）", vbYesNo)
If vtemp = vbYes Then
iflgSum = 1 '件数で集計
Else
iflgSum = 0 '％で集計
End If
vtemp = MsgBox("件数で並替え はい(Y)" & vbCrLf & _
"項目で並替え いいえ(N)" & vbCrLf & _
"何もしない キャンセル", vbYesNoCancel)
If vtemp = vbYes Then
iflgSort = 1 '件数でソート
ElseIf vtemp = vbNo Then
iflgSort = 2
Else
iflgSort = 0 'ソートしない
End If
'データを配列に取得
vRng = Range(Cells(iyS, ixS), Cells(iyE, ixE))
'データの集計
imax = 0
icnt = 0
For Each vcell In vRng
icnt = icnt + 1
If icnt = 1 Then
ReDim xCount(0), xRank(0)
'xRank(0) = ttl
xCount(0) = xCount(0) + 1
xRank(0) = CStr(vcell)
Else
iflg = 0
For i = 0 To imax
If CStr(vcell) = xRank(i) Then
xCount(i) = xCount(i) + 1
iflg = 1
Exit For
End If
Next i
If iflg = 0 Then
imax = imax + 1
ReDim Preserve xCount(imax), xRank(imax)
xCount(imax) = xCount(imax) + 1
xRank(imax) = CStr(vcell)
End If
End If
Next vcell
'ランク数に関するメッセージ
If imax = icnt Then 'ランク数imaxと個数icntが同じ
vtemp = MsgBox("ランク数と個数が同じです。 ランク数=" & imax & " 続けますか？", vbYesNo, "個数ヒストグラム")
ElseIf imax >= 0.3 * icnt Then 'ランク数imaxが個数icntの３０％以上もある
vtemp = MsgBox("ランク数が個数に対して多いです。ランク数=" & imax & " 個数=" & icnt & " 続けますか？", vbYesNo, "個数ヒストグラム")
ElseIf imax >= 100 Then 'ランク数が１００個以上もある
vtemp = MsgBox("ランク数が多いです。ランク数=" & imax & " 個数=" & icnt & " 続けますか？", vbYesNo, "個数ヒストグラム")
Else
vtemp = vbYes
End If
If vtemp = vbNo Then
Exit Sub
End If
If iflgSum = 0 Then '％で集計
For i = 1 To imax
xCount(i) = xCount(i) / icnt * 100
Next i
ElseIf iflgSum = 1 Then '件数で集計
'そのまま
End If
'集計データの並べ替え
If iflgSort = 1 Then
MinSortPareto xCount, xRank, 1 '1は降順
ElseIf iflgSort = 2 Then
MinSortPareto xRank, xCount, 1 '1は昇順
End If
'***ヒストグラム図の作成***
If iflgSum = 0 Then
chartTtl = ttl & " [%]" & " ランク数=" & imax & " 全数=" & icnt
ElseIf iflgSum = 1 Then
chartTtl = ttl & " [pcs]" & " ランク数=" & imax & " 全数=" & icnt
End If
Set objChart = plotHistogram(xRank, xCount, , , chartTtl) ', ACell.Offset(1, 0))
Call moveChartPosVisibleRange(objChart)
ACell.Select
Set objChart = Nothing
Set ACell = Nothing
End Sub