2019/7/2

イントロダクション

このページはパレート図の作成(QC ver.) with Excelの補足ページです。

機能的には簡易なものですが,手続きが煩雑なパレート図の作成をVBA(Visual Basic for Applications)にて自動化を試みます。

免責事項:

  • 掲載のコードは一例として提示しています。諸般のデータに対応するものでも,すべての環境で正常に動作することを保証するものでもありません。
  • [動作確認環境]
    • Windows 7 32bit ServicePack 1 / Excel 2010, 2013(32bit版)
    • Windows 8.1 64bit / Excel 2010, 2013, 2016(32bit版)
    • Windows 10 64bit / Excel 2010, 2013, 2016(32bit版)
  • このコードおよびマクロを利用されたことにより生じた損害,トラブル等につきまして管理者は一切の責任を負いません。

お願い:

  • マクロを利用される場合,万一に備え重要なデータのバックアップをおこなったうえで,事前にテストデータを使って動作を十分に検証されることをおすすめします。

以下,Excel 2010 を使ったパレート図作成マクロの導入の仕方,および利用の仕方に関する解説です(Excel 2013以降であっても同様の手続きで利用できます)。

綾子

元データ

元のデータです。「パレート図の作成(QC ver.) with Excel」の15 時点の表です。

あらためてポイントを示すと以下のとおりです。

  • 項目・件数(個数)・累積比率の3列をこの順番で隣接させて作成
  • 見出し直下の行に累積比率の"0"のみ挿入

このページで扱うマクロは,下の体裁が整えられた表のみ対応できます。

元データ・パレート図

VBEを起動する

リボンの開発タブコードグループにあるVisual Basicボタンをクリックします。

VBE(Visual Basic Editor)が起動します。

メニューの挿入から標準モジュールをクリックすると,エディタにコードウインドウが表示されます。

コードをコピペする

下のコードをすべてコピーします。

Sub PARETOFORQC1_draw()

' パレート図の作成 ver.1.3.1
' 「パレート図の作成(QC ver.) with Excel」で掲載する形式でパレート図を作成するマクロです。
' 元表は掲載の表と同じ体裁(項目・数量・累積比率の3列からなる表)を整えている必要があります。
' 詳細は当該ページ(https://hitorimarketing.net/tools/vba/paretograph-macro.html)をご覧ください。
' ひとりマーケテイングのためのデータ分析(https://hitorimarketing.net/)
' by hawcas 2014, 2016

On Error GoTo myError

Const IntervalY2 As Double = 0.2 ' 第2縦軸の目盛間隔

Dim Target As Range ' 選択範囲
Dim RngInTgt As Range ' Target内範囲
Dim ItemsAtSer1 As Range ' 項目名範囲
Dim NumberAtSer1 As Range ' 件数範囲
Dim parMAX As Variant ' 第1縦軸最大値
Dim parITV As Variant ' 第1縦軸目盛間隔
Dim ShtName As String ' アクティブシート名
Dim SeriesAtGrp As String ' 系列の定義式
Dim i As Long ' ChartObjects(i)

' 選択範囲が妥当か簡易チェック
    Set Target = Selection ' 選択範囲の格納
    If Target.Rows.Count < 4 Or Target.Columns.Count <> 3 Then ' 4行未満または3列以外の選択を弾く
        MsgBox "選択範囲を確認してください。マクロを終了します。", vbOKOnly, "ERROR"
        Exit Sub
    End If

' 第1縦軸パラメータの計算
    Set RngInTgt = Target.Range("b3").Resize(RowSize:=Target.Rows.Count - 2, ColumnSize:=1) ' 件数列のデータ範囲
        parMAX = Application.WorksheetFunction.Sum(RngInTgt) ' 最大値を求める
    If Application.WorksheetFunction.Round(parMAX / 5, -1) > 10 Then ' 目盛間隔を決める
        parITV = Application.WorksheetFunction.Round(parMAX / 5, -1)
    Else
        parITV = Application.WorksheetFunction.Round(parMAX / 5, 0)
    End If

' 集合縦棒グラフの作成
    ActiveSheet.Shapes.AddChart(xlColumnClustered, , , 310, 295).Select ' 幅310pt, 高さ295ptで仮作成
    ActiveChart.SetSourceData Source:=Range(Target.Address) ' データ範囲の指定

' 系列定義式の調整
    i = ActiveChart.Parent.Index
    With ActiveSheet.ChartObjects(i).Chart
        SeriesAtGrp = .SeriesCollection(1).Formula ' 定義式の抽出
        Set ItemsAtSer1 = Target.Range("a3").Resize(RowSize:=Target.Rows.Count - 2, ColumnSize:=1) ' 項目列の調整
        Set NumberAtSer1 = Target.Range("b3").Resize(RowSize:=Target.Rows.Count - 2, ColumnSize:=1) ' 件数列の調整
        ShtName = "'" & ActiveSheet.Name & "'!" ' シート名の格納
        SeriesAtGrp = "=SERIES(" & ShtName & Target.Range("b1").Address _
            & "," & ShtName & ItemsAtSer1.Address & "," & ShtName & NumberAtSer1.Address & ",1)" ' 定義式の作成
        .SeriesCollection(1).Formula = SeriesAtGrp ' 定義式の再格納
    End With

    With ActiveChart
' 線グラフの設定
        With .SeriesCollection(2)
            .ChartType = xlLineMarkers ' マーカー付き折れ線
            .AxisGroup = 2
        End With
    
' 横軸の設定
        With .Axes(xlCategory)
            .TickLabelSpacing = 1
            .MajorTickMark = xlNone
            .TickLabels.Orientation = xlUpward ' 「左へ90度回転」
        End With

' 第2横軸の設定
        .SetElement (msoElementSecondaryCategoryAxisShow)
        .HasAxis(xlCategory, xlSecondary) = True
        With .Axes(xlCategory, xlSecondary)
            .MajorTickMark = xlNone
            .TickLabelPosition = xlNone
            .AxisBetweenCategories = False
            .Format.Line.Visible = msoFalse
        End With

' 縦軸の設定
        .ChartGroups(1).GapWidth = 0
        .HasAxis(xlValue) = True
        With .Axes(xlValue)
            .MinimumScale = 0
            .MaximumScale = Val(parMAX)
            .MajorUnit = Val(parITV)
            .MajorTickMark = xlInside
            .HasTitle = True
            .AxisTitle.Orientation = xlVertical
        End With

' 第2縦軸の設定
        .HasAxis(xlValue, xlSecondary) = True
        With .Axes(xlValue, xlSecondary)
            .MinimumScale = 0
            .MaximumScale = 1
            .MajorUnit = IntervalY2
            .MajorTickMark = xlInside
            .TickLabels.NumberFormatLocal = "0%" ' パーセントスタイル
            .HasTitle = True
            .AxisTitle.Text = "累積比率"
            .AxisTitle.Orientation = xlVertical
        End With
        .SetElement (msoElementPrimaryValueGridLinesNone)
' 凡例
        .HasLegend = False ' 削除

' ※※※グラフタイトルの作成
'       .HasTitle = True
    End With
    
'   With ActiveChart.ChartTitle
'       .Top = 280 ' 上方より280pt
'       .Left = 110 ' 左端より110pt の位置に仮作成
'       With .Font
'           .Size = 12
'           .Bold = False
'       End With
'   End With
' ※※※

' 軸ラベルの作成
    With ActiveChart.Axes(xlValue) ' 第1軸
        .HasTitle = True
        With .AxisTitle.Font
            .Size = 10
            .Bold = False
        End With
    End With
    With ActiveChart.Axes(xlValue, xlSecondary) ' 第2軸
        .HasTitle = True
        With .AxisTitle.Font
            .Size = 10
            .Bold = False
        End With
    End With

' ※※※グラフエリア サイズの調整
'    ActiveChart.ChartArea.Height = 320
' ※※※

' プロットエリア サイズの調整
    With ActiveChart.PlotArea
        .Top = 20 ' 上端より20pt
        .Left = 20 ' 左端より20pt
        .Height = 260 ' 高さ260pt
        .Width = 270 ' 幅270pt で仮調整
    End With
    Exit Sub

myError:
    MsgBox "実行時エラーが発生しました。処理を終了します。"

End Sub


Sub PARETOFORQC2_overlay()

' [パレート図]レイヤーによる Y1軸 ”件数合計” 作成 v.1.1.0
' https://hitorimarketing.net/tools/vba/paretograph-macro.html
' by hawcas 2015, 2016

On Error GoTo myError

Dim parMAX As Variant
Dim Chrts As Variant

' アクティブシートを新規ブックにコピー
Worksheets(ActiveSheet.Name).Copy

' 第1縦軸の最大値を格納
parMAX = ActiveSheet.ChartObjects(1).Chart.Axes(xlValue, xlPrimary).MaximumScale

' ChartObjectの複製
ActiveSheet.ChartObjects(1).Copy
ActiveSheet.Paste
ActiveSheet.ChartObjects(1).Select

' 背面グラフの書式設定
With ActiveChart
    .Axes(xlValue, xlPrimary).HasTitle = False ' 第1縦軸ラベル消去
    .Axes(xlValue, xlPrimary).MajorUnit = parMAX ' 目盛間隔<-MaximumScale
    .Axes(xlValue, xlSecondary).HasTitle = False ' 第2縦軸ラベル消去
    .Axes(xlValue, xlSecondary).TickLabels.Font.Color = RGB(255, 255, 255) ' 第2縦軸文字色→白
    .Axes(xlCategory, xlPrimary).TickLabels.Font.Color = RGB(255, 255, 255) ' 第1横軸文字色→白
    With .SeriesCollection(1)
        .Format.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 系列1塗り色→白
        .Format.Line.ForeColor.RGB = RGB(255, 255, 255) ' 系列1線色→白
        .HasDataLabels = True ' ラベル強制ON
        .DataLabels.Font.Color = RGB(255, 255, 255) ' 系列1データラベル文字色→白
    End With
    With .SeriesCollection(2)
        .Format.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 系列2塗り色→白
        .Format.Line.ForeColor.RGB = RGB(255, 255, 255) ' 系列2線色→白
        .HasDataLabels = True ' ラベル強制ON
        .DataLabels.Font.Color = RGB(255, 255, 255) ' 系列2データラベル文字色→白
    End With
End With

' 前面グラフの書式設定
ActiveSheet.ChartObjects(2).Activate
With ActiveChart
    .ChartArea.Fill.Visible = False ' [グラフエリア]塗りつぶしなし
    .PlotArea.Fill.Visible = False ' [プロットエリア]塗りつぶしなし
End With

' レイヤー化
For Each Chrts In ActiveSheet.ChartObjects
    Chrts.Top = Range("e5").Top
    Chrts.Left = Range("e5").Left ' 上・左の位置:セルE5に合わせる
Next

' グループ化
ActiveSheet.Shapes.SelectAll
Set Chrts = Selection.ShapeRange
Chrts.Group.Select
Range("a1").Select
Exit Sub

myError:
    MsgBox "実行時エラーが発生しました。処理を終了します。"

End Sub

コードを,コードウインドウに貼り付けます。

コードが導入出来たので,VBEを閉じます。

では,ここからマクロの具体的な使い方です。

データ範囲を指定する

晴花

マクロの実行前に,データ範囲を指定しておきます。

項目・件数(個数)・累積比率の隣接する3列すべてのデータを,見出しを含み選択します。ただし,下の図のように最下行に合計行がある表の場合,これを選択範囲に含めません。

マクロを実行する

リボンの開発タブコードグループにあるマクロボタンをクリックします。

マクロダイアログが表示されます。

マクロ名に「PARETOFORQC1_draw」および「PARETOFORQC2_overlay」(いずれもマクロの名前)の2つが表示されていると思います。

前者のPARETOFORQC1_drawの方を選択して,実行ボタンをクリックします。

下のようなパレート図を自動でアウトプットします。

ここにデフォルトの縦軸ラベル名の修正やデータラベルの付加,さらにはグラフサイズの変更など適宜任意の加工をくわえます。

なお,第1縦軸の設定については次のようなルールで処理しています。

  • 【最大値】 件数合計
  • 【目盛間隔】 件数÷5の商が2桁以上のときは商の1桁で四捨五入した値。商が1桁のときは小数点第1位で四捨五入した値。

その他のルールを適用する際は,コードの当該箇所「目盛>>最大値」「目盛>>間隔」のブロックを任意に調整してください。

また,下のグラフのようにグラフタイトル枠がデフォルトで必要となる場合は,コードの中の「※」で囲まれたコメントアウトしてある部分(「'」が先頭についている部分。2ヵ所。「※」の行は含まず)を解除(「'」記号のみ削除)することで対応が可能です。

以上が基本的な使い方ですが

場合によっては,最大件数を表示しても

ここから,少し試行的なプラスアルファの加工をくわえてみたいと思います。


1手前の手順までに作成したパレート図は,第1縦軸の目盛間隔を除算で決定しています。したがって商を四捨五入した値次第で,件数合計の正確なところは表示されません。

Excelの仕様上,仕方のない話ではあるのですが,それでも件数合計が表示されていた方が使い勝手がいいだろうことを容易に想像できます。

となると割り切れるような値で目盛間隔を設定しなおすのもひとつの方法ですが,それによって目盛が多くなりすぎても,少なくなりすぎても「なんか違う」って感じじゃないかと思います。


「なんとかして件数合計を表示できないか」

遊び半分ですが,結局私にはこんな 姑息的対処法が思い浮かんだのでこれをやってみたいと思います。繰り返しますが,以下正攻法ではありません。

  • 2枚のグラフを重ねてパレート図を描く(見た目には1枚)

えーとこの方法はあとからの書式の調整が苦手(とはいえ元図を修正したら再度「PARETOFORQC2_overlay」マクロを実行するだけではありますが)なので,ここで,マクロで描いたパレート図の書式の調整を完全に済ませておきます(たとえば下図が調整をおえたグラフとします) 。

さらには,このマクロは当該シートの上に存在するすべてのオブジェクト(図形・グラフ)を部品として認識する仕様なので,シェイプ等無関係のオブジェクトはシート上から排除しておく必要があります(チェック機構はありません)。

では,操作は1つ元図となるパレート図(先のマクロで作成したもの)が存在するシートをアクティブにした状態から,マクロダイアログを再び表示させ,今度は

  • PARETOFORQC2_overlay

の方を選択して,実行ボタンをクリックします。

すると,

  1. あたらしいブックに元のパレート図をシートごと複写
  2. そこで同じグラフをもう1枚作成(複写)
  3. 第1縦軸の目盛を中心に,計2枚のグラフにいくつかの加工
  4. 2枚のグラフを重ね合わせてグループ化し,(目視の上では)1枚のグラフとする

といった処理を片付けていきます。