ひとりマーケティングのためのデータ分析

手順解説 | Excel(エクセル)でおこなうビジネスデータの分析

VBA
How-to

パレート図 for QC

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

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

以下、Excel 2010 を使った VBA によるパレート図作成マクロの導入方法です(Excel 2007, Excel 2013 および Excel 2016 でもそのままの手続きで利用できます)。


免責事項

  • 掲載するコードは煩雑な手続きをサポートする一例として提示するものです。諸般のデータに対応するものでも、すべての環境で正常に動作することを保証するものでもありません。

[動作確認環境]

  • Windows 7 32bit ServicePack 1 / Excel 2007, 2010, 2013(32bit版)
  • Windows 8.1 64bit / Excel 2007, 2010, 2013, 2016(32bit版)
  • Windows 10 64bit / Excel 2007, 2010, 2013, 2016(32bit版)
  • このコードおよびマクロを利用されたことにより生じた損害、トラブル等につきまして管理者は一切の責任を負いません。

お願い

  • お手持ちのデータでマクロをご利用いただく前に、サンプルデータを使って動作をご検証ください。サンプルデータはサイドバーのリンク先にあります。また、マクロの実行前には、万一に備え大切なデータのバックアップをおこなっていただけますようお願い申し上げます。

元データ

綾子

1

元のデータです。「パレート図の作成(QC ver.) with Excel」の Step 15 までに作成した表です。

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

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

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

※ データはサイドバーのボタンからご利用いただけます。

元データ・パレート図

VBEを起動する

綾子

2

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

綾子

3

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

メニューの挿入から標準モジュールをクリックすると、エディタにコードウインドウが表示されます。こちらにコードを記入していくことになります。

コードをコピペする

綾子

4

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

Sub PARETOFORQC1_draw()

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

綾子

5

コピーしたコードを、コードウインドウに貼り付けます。

綾子

6

以上でコードが導入できました。VBE を閉じます。

では、ここからはパレート図作成マクロの具体的な使い方です。

データ範囲を指定する

晴花

7

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

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

マクロを実行する

晴花

8

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

晴花

9

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

マクロ名に「PARETOFORQC1_draw」および「PARETOFORQC2_overlay」(いずれもマクロの名前)の 2 つが表示されていると思いますので、前者のPARETOFORQC1_drawの方を選択して、実行ボタンをクリックします。

晴花

10

すると、下のようなパレート図が自動的に作成されます。

デフォルトの縦軸ラベル名の修正やデータラベルの付加、さらにはグラフサイズの変更など適宜加工してください。

晴花

11

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

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

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

晴花

12

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

晴花

13

以上、すべてのプロセスは終了です。
が…

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

晴花

14

えーと…。

ここから…少し試行的なプラスアルファの加工を加えてみたいと思います。
とはいえ、場合によって許されるなら………的な加工になりますので要注意です。


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

晴花

15

ここで「件数合計が表示されていた方が使い勝手がいいのに」と考えたとします。

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


そこで、最後の目盛間隔のみ不等間隔になるのを許容できるという条件をおいて、の話になってしまいますが…なんとか件数合計を表示したいと私が思った…と仮定します(最後の目盛幅が極端に狭いものでないとして)。

そこで、何か方法はないかと考えてみても…エクセルの仕様的に…不等間隔な目盛のとりかたは私の知る限りできません…。遊び半分ですが、結局私にはこんな 姑息的対処法が思い浮かんだので…これをやってみたいと思います。繰り返しますが、以下正攻法ではありません。

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

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

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

晴花

16

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

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

晴花

17

すると、

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

…といった流れの処理がはたらきます。


フォント等にもよりますが、ここでのアウトプットは若干の拡大縮小操作にも耐えられるかと思います(ベクタ形式での使用の方が向きますが)。

  • 本頁で使用したデータはすべて架空のものです。また特定の会社等に実在する人物名、および同場所で実際に観測されたデータ群などを根拠にしたものでもありません。
.

LastUpdate

2016.9.25

.
このページの先頭へ