Excel VBAでヒストグラム計算

質問

Excel2003で1000個のデータのヒストグラムを
計算したいと思っています。

シート上でFrequency関数を用いて計算はできるの
ですが、どうしてもマクロで実行したいのですが、
どのような表記をすれば良いのでしょうか？

区間をマクロでインプット形式にして、区間を
入れれば自動的にその区間と度数分布が出てくる
ような仕組みにしたいのですが・・。

説明が不十分で補足等あれば随時したいと思います。
よろしくお願いします。

回答No.3

Wendy02 · ベストアンサー

こんにちは。

＞コードを解読することもできないのですが
今度のものは、私でも、日にちが経てば、読めなくなる可能性が強いです。かなり入念に作りこみました。私は、グラフ作成のVBAは弱いので、下手くそなコードです。

「分析ツール」のアドインは、基本的には入れておいたほうがよいのですね。困ることが出てくるはずですから。その中の１つに、ヒストグラムはありますが、これに関しては、作った人は、QCのヒストグラムを一度も見ていないのかもしれないと思いました。

アドイン（分析ツール）のヒストグラムを真似、私のイメージで直したものを作ってみました。15年前ぐらいに、ヒストグラムを作った経験からすると、本格的なヒストグラムとは大幅に違いますが、一応使えるはずです。

私のほうでは、問題なく動きますが、もし不具合がありましたら、教えてください。

'標準モジュールに貼り付けてください。
'---------------------------------------
Sub FrequencyFunctionUsed()
'Frequency関数を使った方法
Dim InRng As Variant
Dim BinRng As Variant
Dim OutRng As Variant
'グラフが前もってあると誤動作が起こる。
On Error Resume Next
　　　ActiveSheet.ChartObjects.Delete
　　On Error GoTo 0
On Error Resume Next
Set InRng = Application.InputBox("データの先頭にセルを置いてください。", "データ範囲", "$A$1", Type:=8)
On Error GoTo 0
If TypeName(InRng) = "Empty" Then Exit Sub
If TypeName(InRng) <> "Range" Then MsgBox "データはセルでなければなりません。", 16: Exit Sub
Set InRng = Range(InRng, InRng.End(xlDown))

On Error Resume Next
Set BinRng = Application.InputBox("区間の範囲を設定してください。", "区間範囲", Range("B1", Range("B1").End(xlDown)).Address, Type:=8)
On Error GoTo 0
If TypeName(BinRng) = "Empty" Then Exit Sub
If TypeName(BinRng) <> "Range" Then MsgBox "区間範囲はセルでなければなりません。", 16: Exit Sub
Set BinRng = BinRng.Columns(1)
If WorksheetFunction.CountBlank(BinRng) > 0 Then
　 Set BinRng = Range(BinRng.Cells(1, 1), BinRng.Cells(1, 1).End(xlDown))
End If
On Error Resume Next
Set OutRng = Application.InputBox("出力する場所の先頭にセルを置いてください。", "出力範囲", "$D$1", Type:=8)
On Error GoTo 0
If TypeName(OutRng) = "Empty" Then Exit Sub
If TypeName(OutRng) <> "Range" Then MsgBox "データはセルでなければなりません。", 16: Exit Sub
If WorksheetFunction.CountA(OutRng) > 0 Then
　 If MsgBox("元のデータは消去されます。", vbOKCancel) = vbCancel Then Exit Sub
End If
With OutRng
　Range(.Cells(1, 1), .Cells(1, 2).End(xlDown)).ClearContents
　.Cells(, 1).Value = "データ区間": OutRng.Cells(, 2).Value = "頻度"
　.Resize(, 2).HorizontalAlignment = xlCenter
　.Cells(2, 1).Resize(BinRng.Cells.Count).Value = BinRng.Value
　.Cells(2, 2).Resize(BinRng.Cells.Count + 1).FormulaArray = "=FREQUENCY(" & InRng.Address & "," & BinRng.Resize(BinRng.Cells.Count + 1).Address & ")"
　Range(.Cells(1, 1), Cells(1, 1).End(xlDown)).Resize(, 2).Value = Range(.Cells(1, 1), Cells(1, 1).End(xlDown)).Resize(, 2).Value
　If MsgBox("グラフを作成しますか？", vbYesNo) = vbYes Then
　 Set OutRng = OutRng.Resize(BinRng.Cells.Count + 1, 2)
　 Call HistgramChartMaking(OutRng.Columns(2))
　End If
End With
On Error Resume Next
Set InRng = Nothing: Set OutRng = Nothing: BinRng = Nothing
On Error GoTo 0

End Sub

Sub HistgramChartMaking(OutRng As Variant)
Dim myShName As String
Dim myRng As Variant
　　myShName = ActiveSheet.Name
　　Application.ScreenUpdating = False

　　If TypeName(OutRng) <> "Range" Then Exit Sub
　　On Error Resume Next
　　Set myRng = Application.InputBox("グラフの範囲を決めてください。", "グラフ範囲", "G1:L20", Type:=8)
　　If VarType(myRng) = vbEmpty Then Exit Sub
　　On Error Resume Next

　　If TypeName(myRng) <> "Range" Then Exit Sub
　　Set myRng = myRng.Resize(20, 6)
　 With Charts.Add
　　 .ChartType = xlBarClustered
　　 .SetSourceData Source:=OutRng, _
　　　PlotBy:=xlColumns
　　 .Location Where:=xlLocationAsObject, _
　　　Name:=myShName
　　End With
　　With ActiveChart
　　　　.ChartGroups(1).Overlap = 0
　　　　.ChartGroups(1).GapWidth = 0
　　　　.HasTitle = True
　　　　.Axes(xlCategory).ReversePlotOrder = True
　　　　.ChartTitle.Characters.Text = "ヒストグラム"

　　　　.Axes(xlCategory).ReversePlotOrder = True
　　　　.Axes(xlCategory, xlPrimary).HasTitle = True
　　　　.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "データ区間"
　　　　.SeriesCollection(1).XValues = OutRng.Offset(1, -1)
　　End With
　　With ActiveSheet.Shapes(ActiveChart.Parent.Name)
　　　 .Left = myRng.Left
　　　 .Top = myRng.Top
　　　 .Width = myRng.Width
　　　 .Height = myRng.Height
　　End With
　　OutRng.Cells(1, 1).Select
　　Application.ScreenUpdating = True
　　Set myRng = Nothing
End Sub

お礼

ご回答ありがとうございます！
とっても親身になっていただき、助かります！！
コードはちょっとわからないですけど、結果は
こーゆうのをイメージしてました♪

Frequency関数も組み込まれているようで、
ちょっとこれを見ながら改造してみます☆

いろいろほんとありがとうございます。
助かりました！

回答No.4

Wendy02

こんばんは。

英語のスペルを間違えました。
"Histogram" でした。

このページをみると、やっぱり、米国では、一般のグラフのように作るのかしらね。
私が作ってきたものと、ずいぶんイメージが違います。

http://office.microsoft.com/en-us/assistance/HA010346381033.aspx

http://www.ozgrid.com/Services/excel-histogram-chart.htm

なお、
Sub HistogramChartMaking(OutRng As Variant)

このコードは、ダブりです。
.Axes(xlCategory).ReversePlotOrder = True
ひとつにしてください。

また、

縦・横の問題はあまりたいしたことではないので、修正は、

.ChartType = xlBarClustered　''横棒
　　↓
.ChartType = xlColumnClustered ''縦棒

これをコメントアウトか、削除します。
.Axes(xlCategory).ReversePlotOrder = True

なお、これ以上のオプションは、ここの掲示板では公開はするつもりはありません。区分の決め方、グラフの中心値や上限・下限の表示、また、近似曲線などを加える必要がありそうです。

お礼

ご回答ありがとうございました！
おかげさまで、とりあえずヒストグラムを即時に
表示させ、業務に活用することができそうです。
親身に対応していただきありがとうございました。

回答No.2

imogasi

ヒストグラムを作成するには
（１）投げ入れ法(私の自称）
（２）ソート法（私の自称）
（３）Ｆｒｅｑｕｅｎｃｙ関数の代替のアドインの利用（＃１のご回答）
http://support.microsoft.com/default.aspx?scid=kb;en-us;270844
（１）投げ入れ法で、下記の通り簡単にできそうなので
例データＡ１：Ａ１５
12
34
23
45
45
123
34
56
3
4
5
20
23
223
546
どこでも良いがＣ１：Ｃ５に
Ｃ列　Ｄ列
0 6
10 18
100 4
300 1
600
正の数値の場合、一番上に０、最後に最大値＋アルファの値（上例では６００）を
入れておくこと。（ＶＢＡでセットもできますが）
Sub test01()
Dim a As Range
Dim b As Range
Dim cl1 As Range
Dim cl2 As Range
'---
Set a = Application.InputBox("対照データ範囲", Type:=8)
Set b = Application.InputBox("区間指定範囲", Type:=8)
'-----
For Each cl1 In a
For Each cl2 In b
If cl1 >= cl2 And cl1 < cl2.Offset(1, 0) Then
cl2.Offset(0, 1) = cl2.Offset(0, 1) + 1
End If
Next
Next
End Sub
結果は上記Ｄ列の通り。
素朴なコードのままで、チェックを入れたりして、細部には要修正かも知れませんが、アイデアを汲み取ってもらえば。
ソート法は、データ全体を大小順に一旦並べて（エクセルの場合はワーク列を利用か）、区間を超えるまでその区間に＋１(件）してゆく方法を考えてます。

お礼

ご回答いただきありがとうございました♪
投げ入れ法いいですね～！とてもシンプルですね。

エクセルのシート上で記述できるFrequency関数を
VBAの方で計算させて、結果だけ出力させる方法って
あるんですかねー？

回答No.1

Wendy02

こんばんは。

こんな風でよいのでは？

Application.Run "ATPVBAEN.XLA!Histogram",データ範囲,出力範囲,区間範囲,パレート,度数分布表,グラフ,ラベル

この３つはRange型
データ範囲,出力範囲,区間範囲

この４つは、Boolean値
パレート,度数分布表,グラフ,ラベル

'<標準モジュール>
'-------------------------------------
Sub HistGramTest()
　 Dim BinRng As Variant
　 With ActiveSheet
　　　If WorksheetFunction.CountA(.Range("D1:D15")) > 0 Then
　　　　 .Range("D1:D15").Resize(, 4).ClearContents
　　　　 .ChartObjects(1).Delete
　　　End If
　　　On Error Resume Next
　　　Set BinRng = Application.InputBox("区間範囲を指定してください。", Type:=8)
　　　On Error GoTo 0
　　　If VarType(BinRng) = vbBoolean Then Exit Sub
　　　Set BinRng = BinRng.Columns(1)　'エラー防止
　　　Application.Run "ATPVBAEN.XLA!Histogram", .Range("A1", .Range("A65536").End(xlUp)), .Range("D1:D15"), BinRng, False, False, True, False　'True は、グラフ出力
　 End With
End Sub

'

お礼

早速ご丁寧なご回答をいただき、ありがとうございます。
まだまだ未熟なもので、コードを解読することもできないのですが、アドインの分析ツールが使えないPCでも使いたいと思っています。
そちらの方で何か良案があればお教えいただきたいのですが。