統計教育の必要性が叫ばれ始めて随分と経つそうだ.
そして今年度もやがて始まる講義,統計とコンピュータ用に作ってみた.
講義内容・方法を全面的に変えようと画策しているが,未だ目処が立たず.
ちょっと気が滅入ってきている今日このごろ.
五数要約と平均値が書かれていれば,その範囲を選択して【Ctrl+b】をすると
そのシートに箱ひげ図ができあがる,というものだ.
2015/04/27 修正!
項目の方向を自動判定させず常に
横方向が項目となるようにした.
余分な系列が表示されていたので消した.
散布図で平均の位置を描いていたのを変更.
項目が文字だとエラーが出るので訂正した.
あちこちサイトを回ってかき集めた情報で何とか作ったシロモノなので,ソースは汚い.
サーフィンしてみてわかったけど,苦労している人が多そうだから
ここにのっけておく.結構需要高いと思う.
あ,エラー対策してないから,間違った範囲選択でCtrl+bするとマクロ画面に変わります.
20150427_boxplot_macro.xlsm
Sub boxplot() ' ' boxplot Macro ' ' 五数要約(上から順に,最大・第3四分位・中央・第1四分位・最小値・平均値)とした表から ' 箱ひげ図を作る ' ' Ver. 2015/04/27 ' http://tokidoki.hatenablog.jp/ ' ' Keyboard Shortcut: Ctrl+b ' Dim box0, dWisker, uWisker, Mean ActSht = ActiveSheet.Name 'アクティブシート名取得 Set ActArea = Selection ActCell = ActArea.Address '選択範囲のアドレスを取得(項目名,最大~平均値を囲う) box0 = Range(ActCell) UB = UBound(box0, 2) UBB = UBound(box0, 1) ReDim boxName(1 To UB) '(1,i):項目名 ReDim boxLB(1 To UB) '(2,i):箱の下境界 ReDim boxMid(1 To UB) '(3,i):中央線まで ReDim boxUB(1 To UB) '(4,i):箱の上境界まで ReDim dWisker(1 To UB) '(5,i):下ヒゲ長 ReDim uWisker(1 To UB) '(6,i):上ヒゲ長 ReDim Mean(1 To UB) '(7,i):平均値 '五数要約からグラフ表示用のデータに変換 For i = 1 To UB boxName(i) = box0(1, i) boxLB(i) = box0(5, i) boxMid(i) = box0(4, i) - box0(5, i) boxUB(i) = box0(3, i) - box0(4, i) dWisker(i) = box0(6, i) - box0(5, i) uWisker(i) = box0(2, i) - box0(3, i) Mean(i) = box0(7, i) Next i 'メインの箱の系列データをセット,グラフをSheet内に配置 Charts.Add With ActiveChart .ChartType = xlColumnStacked .PlotBy = xlRows .SeriesCollection(6).Delete .SeriesCollection(5).Delete .SeriesCollection(4).Delete .SeriesCollection(1).XValues = boxName .SeriesCollection(1).Values = boxLB .SeriesCollection(2).Values = boxMid .SeriesCollection(3).Values = boxUB .HasLegend = False .Location Where:=xlLocationAsObject, Name:=ActSht End With 'メインの箱の色と線を変更 ActiveChart.SeriesCollection(1).Select Selection.Format.Fill.Visible = msoFalse ActiveChart.SeriesCollection(2).Select With Selection.Format.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent5 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0.6 .Transparency = 0 .Solid End With With Selection.Format.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 End With ActiveChart.SeriesCollection(3).Select With Selection.Format.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent5 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0.6 .Transparency = 0 .Solid End With With Selection.Format.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 End With '上下のひげ.ただし下ヒゲもxlErrorBarIncludePlusValuesで行ったので, '使う値dWisker()は負になるよう計算してある. With ActiveChart .SeriesCollection(3).HasErrorBars = True .SeriesCollection(3).ErrorBar Direction:=xlY, Include:= _ xlPlusValues, Type:=xlErrorBarTypeCustom, amount:=0 .SeriesCollection(3).ErrorBar Direction:=xlY, Include:= _ xlErrorBarIncludePlusValues, Type:=xlErrorBarTypeCustom, amount:=uWisker .SeriesCollection(1).HasErrorBars = True .SeriesCollection(1).ErrorBar Direction:=xlY, Include:= _ xlErrorBarIncludePlusValues, Type:=xlErrorBarTypeCustom, amount:=dWisker End With '平均値をマーカーのみの折れ線グラフで追加 With ActiveChart .SeriesCollection.NewSeries .SeriesCollection(4).Values = Mean .SeriesCollection(4).ChartType = xlLineMarkers '折れ線グラフ .SeriesCollection(4).Select End With With ActiveChart.SeriesCollection(4) .MarkerStyle = 4 'マーカーは× .MarkerSize = 8 .Format.Fill.Visible = msoFalse 'マーカーを塗りつぶさない .Format.Line.Visible = msoFalse '折れ線は消す .MarkerForegroundColor = RGB(255, 0, 0) 'マーカーは赤で End With ActiveChart.Axes(xlValue).MajorGridlines.Delete ' 横目盛線消去 End Sub