Excelの拡張機能（データ分析）にヒストグラムを作る機能はありますが、あらかじめデータ区分作る必要があり、パッとヒストグラムを見たいときには不便です。そこで、選択しているシートの範囲をそのままヒストグラムにするVBAを作りました。
機能、使い方は
１．選択する範囲は、矩形範囲でも、はなれていても良い。
２．選択後にマクロ「選択範囲ヒストグラム作成」を起動する。
３．データの区間はマクロで設定する。聞いてくるので修正できます。
４．ヒストグラムのデータは、シートに作成しない。
Sub 選択範囲ヒストグラム作成()
Dim xCount() As Long, xRank() As Double
Dim ix As Long, i As Long, imax As Long
Dim xmax As Double, xmin As Double, xstep As Double
Dim xsum As Double, xcnt As Long
Dim iy As Long ', iyS As Long, iyE As Long
Dim strtemp As String, xbuf As Variant, iflg As Integer
Dim objChart As Object, chartTtl As String, xStr As Variant
Dim rng As Range, cl As Variant
'データの取得と区分のカウント
Set rng = Selection
For Each cl In rng
iy = cl.Row
ix = cl.Column
If IsNumeric(cl) = True And cl.Text <> "" Then
If iflg = 0 Then
xmax = cl.Value
xmin = xmax
iflg = 1
End If
xsum = xsum + cl.Value
xcnt = xcnt + 1
If xmax < cl.Value Then xmax = cl.Value
If xmin > cl.Value Then xmin = cl.Value
End If
Next cl
If xmax = xmin Or xcnt = 0 Then
MsgBox "数値のセルを選択してから実行してください。" & " min=" & CStr(Round(xmin)) & " max=" & CStr(Round(xmax))
Exit Sub
End If
'***ヒストグラムデータの作成***
'xmaxの桁で区分幅xstepを設定、その桁で最大最少を設定。必要なら値は入力しなおす。
xstep = 10 ^ (Int(Log(xmax - xmin) / Log(10)) - 1)
strtemp = CStr(xstep * Round(xmin / xstep)) & "," & CStr(xstep * Round(xmax / xstep)) & "," & CStr(xstep)
strtemp = InputBox("区分を入力してください。開始値 終了値 ステップ値", "区分の設定", 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)
xStr(i) = CStr(xRank(i)) & "～"
Next i
xStr(0) = "～" & CStr(xRank(1))
'データのランクへのカウント
For Each cl In rng
If IsNumeric(cl.Value) = True Then '数値の時だけ処理する
iflg = 0
For i = 1 To UBound(xRank)
If cl.Value < 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
'***ヒストグラム図の作成***
chartTtl = "min=" & CStr(xmin) & " max=" & CStr(xmax) & _
" mean=" & CStr(xsum / xcnt) & " n=" & xcnt & " cond=" & strtemp
Set objChart = plotHistogram(xStr, xCount, , , chartTtl) ', rng(rng.Count).Offset(1, 0))
Call moveChartPosVisibleRange(objChart)
rng.Select
Set rng = Nothing
Set objChart = Nothing
End Sub
'チャートを見える範囲内に移動する。addOffsetは内側へ入れるセル数
Function moveChartPosVisibleRange(chartObj As Object, _
Optional addOffsetRow As Long = 1, Optional addOffsetCol As Long = 1)
Dim VR As Range
Dim cl As String, TL As Range, BR As Range
Dim mvRow As Long, mvCol As Long
Dim AC As Range
Set AC = ActiveCell
chartObj.Activate
With chartObj
'画面範囲と現在のチャートの左上、右下
Set VR = ActiveWindow.VisibleRange
Set TL = .TopLeftCell
Set BR = .BottomRightCell
'現在のチャートの左上、右下が画面範囲外にある時の移動量を決める。両方の場合右下を優先する（後で計算する）。
If TL.Row < VR(1).Row + addOffsetRow Then
mvRow = VR(1).Row - TL.Row + addOffsetRow
End If
If TL.Column < VR(1).Column + addOffsetCol Then
mvCol = VR(1).Column - TL.Column + addOffsetCol
End If
If BR.Row > VR(VR.Count).Row - addOffsetRow Then
mvRow = VR(VR.Count).Row - BR.Row - addOffsetRow
End If
If BR.Column > VR(VR.Count).Column - addOffsetCol Then
mvCol = VR(VR.Count).Column - BR.Column - addOffsetCol
End If
'ありえない位置への移動は修正
If TL.Row + mvRow < 1 Then mvRow = 1 - TL.Row
If BR.Row + mvRow > Rows.Count Then mvRow = Rows.Count - BR.Row
If TL.Column + mvCol < 1 Then mvCol = 1 - TL.Column
If BR.Column + mvCol > Columns.Count Then mvCol = Columns.Count - BR.Column
'チャートの左上の位置を変更
cl = TL.Address(False, False)
cl = Range(cl).Offset(mvRow, mvCol).Address(False, False)
.Top = Range(cl).Top
.Left = Range(cl).Left
End With
AC.Select
Set AC = Nothing
Set VR = Nothing
Set TL = Nothing
Set BR = Nothing
End Function
Function plotHistogram(xdata As Variant, ydata As Variant, _
Optional xttl As String, Optional yttl As String, Optional chartTtl As String = "title", _
Optional BarRGB As Long = 16761024)
'Optional posChart As Range, _
Dim oChart As ChartObject
Dim AC As Range
Set AC = ActiveCell
'チャートオブジェクトを適当な位置で作成する
ActiveCell.Resize(5, 1).Select
Set oChart = ActiveSheet.ChartObjects.Add(10, 10, 300, 200)
oChart.Activate
With oChart.Chart
.ChartType = xlColumnClustered 'グラフ形式を設定。縦棒グラフ
'これを繰り返すと複数のラインが描ける
With .SeriesCollection.NewSeries
'.Name = "ChartTitle"
.Values = ydata '１軸目の値
If IsEmpty(xdata) = False Then
.XValues = xdata
End If
.Format.Line.ForeColor.RGB = RGB(0, 0, 0) '棒グラフの外枠の色
.Format.Fill.ForeColor.RGB = BarRGB '棒グラフの色
End With
.ChartGroups(1).GapWidth = 0 '棒グラフの間隔
If xttl <> "" Then
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = xttl
End If
If yttl <> "" Then
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = yttl
End If
End With '.HasTitle = Trueにならないことがあるため入れてみた。
With oChart.Chart '.HasTitle = Trueにならないことがあるため入れてみた。
DoEvents '.HasTitle = Trueにならないことがあるため入れてみた。
If .HasTitle = False Then
.HasTitle = True 'グラフタイトル
End If
With .ChartTitle
.Text = chartTtl
.Format.TextFrame2.TextRange.Font.Size = 11
.Format.TextFrame2.TextRange.Font.Bold = msoFalse
End With
.HasLegend = False '凡例表示
End With
AC.Select
Set plotHistogram = oChart
Set oChart = Nothing
Set AC = Nothing
End Function