HOME TOOLS

2023/7/10

イントロダクション

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

手続きが煩雑なパレート図の作成について，VBA(Visual Basic for Applications)にて自動化を試みます。

具体的には，まずは下図，Excelバージョン2010以降に対応する「TYPE 1」形状のパレート図を描くことを可能とします。QC型にユニークかつベーシックな諸点を押さえてありますが，

パラメータを変更することで，ラベルやマーカーを除いたりといったカスタマイザブルな構成にしています。

いまひとつは，下図，Excelバージョン2013以降に対応する「TYPE 2」形状のパレート図を描くことを試みます。

このTYPE 2はTYPE 1を素材とする図で，ゆえにTYPE 2を目的とした場合には，TYPE 1の工程→TYPE 2の工程，と2段階の工程を経る必要があります。TYPE 2ではTYPE 1に加えて不等間隔な目盛りを用いて件数合計を表示するなど，Excelの標準機能だけでは加工困難なパーツにも手を加えます。

またTYPE 2でも同様，パラメータを変更することで，件数合計を目盛りと一体化させたり，横軸ラベルを段違いに表示させるなどのカスタマイズが可能な構成です。

免責事項:

  • 掲載のコードは一例として提示しています。諸般のデータに対応するものでも，すべての環境で正常に動作することを保証するものでもありません。
  • このコードおよびマクロを利用されたこと，あるいはそれに付随する行為により生じた損害，トラブル等につきまして筆者は一切の責任を負いません。

その他特記の必要なこと:

  • ほとんどの過程でエラー処理を無視しています。指定範囲の誤りや，範囲内の値・文字列が想定されたものでなかった場合，進行不能となりエラーが出ます。

以下，サブスクリプション版Excel(ver.2005)を使った具体的な手続きです。

綾子

元データ

元のデータです。

項目，件数，累積比率の3要素からなる元表を，あたらしいブックの任意のシートに下図のように用意しておきます。

このとき，

  • 内容を問わず見出しは3つとも必須(どんな文字列であれOK)。

ことだけ注意が必要です。

VBEを起動する

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

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

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

コードをコピペする

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

Option Explicit
Option Base 1

' PARETOGRAPH 2020.0705
' hitorimarketing.net/tools/vba/paretograph-macro.html
' by hawcas 2014, 2016, 2020

' TYPE1 PARAMETER
Const LineMarkers = True ' 線グラフに四角形のマーカーを表示させるか
Const DatalabelsOnBars = True ' 棒グラフの上にデータラベルを表示させるか
Const DatalabelsOnLine = True ' 線グラフの上にデータラベルを表示させるか
Const BarColorRGB = "42,42,42" ' 棒グラフの色(RGB)
Const LineColorRGB = "153,153,153" ' 線グラフの色(RGB)

' TYPE2 PARAMETER
Const N_OnYAxis = False ' N数をグラフのY1軸頂上に目盛として表示するか
                      ' (Falseの場合，グラフ左上角に"N="で表示)
Const AxisColorRGB = "120,120,120" 'Y1,Y2軸の線の色(RGB)
Const AxisLineWeight = 0.5 'Y1,Y2軸の線の太さ(pt)
Const UnevenDataLabels = False ' X軸ラベルを段違いに表示するか

Sub PARETO_FOR_QC_TYPE1()
' パレート図 TYPE 1

Application.ScreenUpdating = False

Dim x As Long, y As Long, z As Long ' Counter

Dim target ' Object
Set target = Selection

' あたらしいシートを右に挿入し，元表を転記する
Dim sheetName As String
sheetName = ActiveSheet.Name
Worksheets.Add after:=Worksheets(sheetName)

sheetName = ActiveSheet.Name
z = target.Rows.Count
If z > 31 Then ' 上限チェック
    Call ERR_MSG3
    Exit Sub
End If

For y = 1 To z
    For x = 1 To 3
        Cells(y, x) = target.Range("a1").Offset(y - 1, x - 1)
    Next x
Next y

' 転記した表の2行目に0値を差し込む
Range("a2:c2").Insert shift:=xlShiftDown
Range("c2") = 0

' グラフのデータソースを作成
Set target = Nothing
Set target = Range("c2").CurrentRegion
target.Select
z = target.Rows.Count

' 集合縦棒グラフを挿入
ActiveSheet.Shapes.AddChart(xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range(target.Address)

Dim idx As Long ' チャートのインデックスNo
idx = ActiveChart.Parent.Index

With ActiveSheet.ChartObjects(idx).Chart
' 累積比率を第2軸・散布図に
    With .SeriesCollection(2)
        If LineMarkers Then
            Call PUT_LINE_MARKERS(z - 2)
        Else
            .ChartType = xlXYScatterLinesNoMarkers ' マーカーなし散布図
        End If
        .AxisGroup = 2
    End With

' 件数について，グラフソースを変更
    Dim formulaStrings As String ' 定義式
    Dim categoryRange As Range ' 項目名範囲
    Dim valueRange As Range ' 件数範囲
    Set categoryRange = target.Range("a3").Resize(RowSize:=z - 2, ColumnSize:=1)
    Set valueRange = target.Range("b3").Resize(RowSize:=z - 2, ColumnSize:=1)
    sheetName = "'" & sheetName & "'!"
    ' 定義式の作成
    formulaStrings = _
        "=SERIES(" & sheetName & target.Range("b1").Address _
        & "," & sheetName & categoryRange.Address & "," & _
        sheetName & valueRange.Address & ",1)"
    .SeriesCollection(1).Formula = formulaStrings ' 定義式の再格納
    
    ' 件数の合計を表の直下に付置
    formulaStrings = Range(Cells(3, 2), Cells(z, 2)).Address
    Cells(y + 1, 1) = "計"
    Cells(y + 1, 2) = "=sum(" & formulaStrings & ")"
    Dim totalNumber As Double ' 件数の合計
    totalNumber = Cells(y + 1, 2)

    ' 第1横軸の設定
    With .Axes(xlCategory)
        .TickLabelSpacing = 1
        .MajorTickMark = xlNone
        '.TickLabels.Orientation = xlUpward ' 文字方向:左へ90度回転
    End With

    ' 第2横軸の設定
    With .Axes(xlCategory, xlSecondary)
        .MajorTickMark = xlNone
        .TickLabelPosition = xlNone
        .Format.Line.Visible = msoFalse
        .MinimumScale = 1
        .MaximumScale = z - 1
    End With

    ' 第1縦軸の設定
    .ChartGroups(1).GapWidth = 0
    With .Axes(xlValue)
        .MinimumScale = 0
        .MaximumScale = totalNumber
        .MajorTickMark = xlInside
        .HasTitle = True
        .AxisTitle.Text = "件数"
        '.AxisTitle.Orientation = xlVertical ' 文字方向:縦
    End With

    ' 第2縦軸の設定
    .HasAxis(xlValue, xlSecondary) = True
    With .Axes(xlValue, xlSecondary)
        .MinimumScale = 0
        .MaximumScale = 1
        .MajorUnit = 0.1
        .MajorTickMark = xlInside
        .TickLabels.NumberFormatLocal = "0%" ' パーセントスタイル
        .HasTitle = True
        .AxisTitle.Text = "累積比率"
        '.AxisTitle.Orientation = xlVertical ' 文字方向:縦
    End With
    
    Dim rgbArray ' RGBcolor
    rgbArray = Split(expression:=BarColorRGB, delimiter:=",")
    With .SeriesCollection(1).Format
        .Fill.ForeColor.RGB = RGB(rgbArray(0), rgbArray(1), rgbArray(2))
        .Line.ForeColor.RGB = RGB(255, 255, 255)
    End With
        
    rgbArray = Split(expression:=LineColorRGB, delimiter:=",")
    With .SeriesCollection(2).Format
        .Line.ForeColor.RGB = RGB(rgbArray(0), rgbArray(1), rgbArray(2))
    End With
    
    ' 目盛線の削除
    .SetElement (msoElementPrimaryValueGridLinesNone)

    ' 凡例の削除
    .HasLegend = False

    ' 棒上のデータラベル
    If DatalabelsOnBars Then
        .SeriesCollection(1).HasDataLabels = True
    End If

    ' 線上のデータラベル
    If DatalabelsOnLine Then
        With .SeriesCollection(2)
            .HasDataLabels = True
            .DataLabels.Position = xlLabelPositionAbove ' ラベルの位置
            .DataLabels.NumberFormatLocal = "0.0%" ' パーセントスタイル
            .Points(1).DataLabel.ShowValue = False ' 0%のラベルを不可視に
            .Points(z - 1).DataLabel.ShowValue = False ' 100%のラベルを不可視に
            If DatalabelsOnBars And _
                target.Range("b3") - target.Range("b4") > totalNumber * 0.12 Then ' ラベルの衝突回避
                .Points(2).DataLabel.Position = xlLabelPositionRight
            End If
        End With
    End If

End With ' ActiveSheet.ChartObjects(idx).Chart

' 目盛間隔の目安, 目盛線の長さをディスプレイして完了(TYPE2の布石)
' 目盛間隔についてのアルゴリズムは imagingsolution.net/program/autocalcgraphstep/ より引用
Cells(y + 3, 1) = "目盛間隔の目安"
Cells(y + 4, 1) = "Y1軸"
Cells(y + 5, 1) = "Y2軸"
    
Dim exponent As Double ' 指数
Dim significand As Double ' 仮数
Dim y1Interval As Double ' Y1の目盛間隔
Const y2Interval As Double = 0.2 ' Y2の目盛間隔

If CInt(Application.Version) = 14 Then ' v2010
    exponent = Application.WorksheetFunction.Power(10, _
        Int(Application.WorksheetFunction.Log10(totalNumber))) ' Floor_Mathをintで代用
Else ' v2013-
    exponent = _
        Application.WorksheetFunction.Power(10, _
        Application.WorksheetFunction.Floor_Math(Application.WorksheetFunction.Log10(totalNumber)))
End If
significand = totalNumber / exponent
If significand < 1.5 Then
    y1Interval = 0.2 * exponent
ElseIf significand < 3.5 Then
    y1Interval = 0.5 * exponent
ElseIf significand <= 5 Then
    y1Interval = 1 * exponent
Else
    y1Interval = 2 * exponent
End If
Cells(y + 4, 2) = y1Interval
Cells(y + 5, 2) = y2Interval

Cells(y + 7, 1) = "目盛線の長さ"
Cells(y + 7, 2) = 0.15

Application.ScreenUpdating = True

End Sub

Sub PARETO_FOR_QC_TYPE2()
' パレート図 TYPE2

Application.ScreenUpdating = False

Dim target
Set target = Range("a1").CurrentRegion
Range("e:p").Clear ' e:p列のクリア

Call PUT_HEADERS(target)
Call PUT_SERIES(target)

Application.ScreenUpdating = True

End Sub

Private Sub PUT_LINE_MARKERS(ByVal size As Long)
' 線グラフ上ににマーカーを付置

With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(2)
    .ChartType = xlXYScatterLines ' マーカーあり散布図
    .MarkerStyle = xlMarkerStyleSquare ' 四角形マーカー
    .MarkerSize = 6 ' マーカーの大きさ
    .Format.Line.Weight = 2 ' 線の太さ
    .MarkerBackgroundColor = RGB(255, 255, 255) ' マーカーの背景色: 白
    .Points(1).MarkerBackgroundColorIndex = xlNone ' 最初と最後の塗り色を削除
    .Points(size + 1).MarkerBackgroundColorIndex = xlNone
End With

End Sub

Private Sub PUT_HEADERS(ByVal target As Variant)
' TYPE1シートの上にTYPE2グラフ用の座標リストをつくる

Dim x As Long, y As Long, z As Double ' Counter

If Y1IntRef(target) > TotalRef(target) Then ' Y1軸目盛間隔が適切か確認
    Call ERR_MSG1
    Exit Sub
End If

If 100 Mod Y2IntRef(target) * 100 <> 0 Or Y2IntRef(target) * 100 > 100 Then
    ' Y2軸目盛間隔が適切か確認
    Call ERR_MSG2
    Exit Sub
End If

Dim xyList ' 座標リストの始点セル
Set xyList = Range("e1")

With xyList
    ' List Y1V, Y1MAX
    .Offset(0, 0) = "Y1V": .Offset(5, 0) = "Y1MAX"
    .Offset(1, 0) = "X": .Offset(6, 0) = "X"
    .Offset(1, 1) = "Y": .Offset(6, 1) = "Y"
    .Offset(6, 2) = "LAB"
    .Offset(2, 0) = 1: .Offset(3, 0) = 1
    .Offset(2, 1) = 0: .Offset(3, 1) = 1
    If N_OnYAxis = True Then
        .Offset(7, 0) = 1: .Offset(7, 1) = 1
        .Offset(7, 2) = TotalRef(target)
    Else
        .Offset(7, 0) = 1.5: .Offset(7, 1) = 1
        .Offset(7, 2) = "N=" & TotalRef(target)
    End If
    .Offset(0, 8) = "Y1V"
    .Offset(0, 9) = .Offset(2, 0).Address & ":" & .Offset(3, 0).Address
    .Offset(0, 10) = .Offset(2, 1).Address & ":" & .Offset(3, 1).Address
    .Offset(1, 8) = "Y1MAX"
    .Offset(1, 9) = .Offset(7, 0).Address
    .Offset(1, 10) = .Offset(7, 1).Address
    .Offset(1, 11) = .Offset(7, 2).Address
End With

Set xyList = Range("i1")

With xyList
    ' List Y1H
    .Offset(0, 0) = "Y1H"
    .Offset(1, 0) = "X": .Offset(1, 1) = "Y": .Offset(1, 2) = "Y'"

    Dim upper As Long
    Dim addNumber As Long
    If ModChecker(TotalRef(target), Y1IntRef(target)) <> 0 Then
        addNumber = 2
    Else
        addNumber = 1
    End If
    upper = _
        Application.WorksheetFunction.Quotient(TotalRef(target), Y1IntRef(target)) _
        + addNumber
    y = 2
    z = 0
    For x = 1 To upper
        If z > TotalRef(target) Then
            z = TotalRef(target)
        End If
        .Offset(y, 0) = 1: .Offset(y + 1, 0) = "=1+" & _
            target.Range("b3").End(xlDown).Offset(6, 0).Address
        .Offset(y, 1) = z: .Offset(y + 1, 1) = z
        .Offset(y, 2) = z / TotalRef(target): .Offset(y + 1, 2) = z / TotalRef(target)
        y = y + 3
        z = z + Y1IntRef(target)
    Next x
    .Offset(2, 4) = "Y1H"
    .Offset(2, 5) = .Offset(2, 0).Address & ":" & .Offset(y - 2, 0).Address
    .Offset(2, 6) = .Offset(2, 2).Address & ":" & .Offset(y - 2, 2).Address
    Dim buf As Long ' Buffer
    buf = y
    
    ' List Y2V
    .Offset(y, 0) = "Y2V"
    .Offset(y + 1, 0) = "X": .Offset(y + 1, 1) = "Y": .Offset(y + 1, 2) = "LAB"
    z = 0
    y = y + 2
    Dim categorySize As Long ' 項目の数
    categorySize = target.Rows.Count - 3
    Do While (Y2IntRef(target) * z) * 100 <= 100
        .Offset(y, 0) = categorySize + 1
        .Offset(y, 1) = Y2IntRef(target) * z
        .Offset(y, 2) = .Offset(y, 1) * 100
        y = y + 1
        z = z + 1
    Loop
    .Offset(3, 4) = "Y2V"
    .Offset(3, 5) = .Offset(buf + 2, 0).Address & ":" & .Offset(y - 1, 0).Address
    .Offset(3, 6) = .Offset(buf + 2, 1).Address & ":" & .Offset(y - 1, 1).Address
    .Offset(3, 7) = .Offset(buf + 2, 2).Address & ":" & .Offset(y - 1, 2).Address
    buf = y
    
    ' List Y2H
    .Offset(y + 1, 0) = "Y2H"
    .Offset(y + 2, 0) = "X": .Offset(y + 2, 1) = "Y"
    upper = Application.WorksheetFunction.Quotient(1, Y2IntRef(target)) + 1
    y = y + 3
    z = 0
    For x = 1 To upper
        If z > 1 Then
            z = 1
        End If
            .Offset(y, 0) = "=" & categorySize & "+1-" & _
                target.Range("b3").End(xlDown).Offset(6, 0).Address
            .Offset(y + 1, 0) = categorySize + 1
            .Offset(y, 1) = z: .Offset(y + 1, 1) = z
        y = y + 3
        z = (z + Y2IntRef(target)) * 100 / 100
    Next x
    .Offset(4, 4) = "Y2H"
    .Offset(4, 5) = .Offset(buf + 3, 0).Address & ":" & .Offset(y - 2, 0).Address
    .Offset(4, 6) = .Offset(buf + 3, 1).Address & ":" & .Offset(y - 2, 1).Address
    buf = y

    ' List X1H
    .Offset(y, 0) = "X1H"
    .Offset(y + 1, 0) = "X": .Offset(y + 1, 1) = "Y": .Offset(y + 1, 2) = "LAB"
    z = 0
    y = y + 2
    For x = 1 To categorySize
        .Offset(y, 0) = x + 0.5
        .Offset(y, 1) = 0
        If x Mod 2 = 0 Then
            .Offset(y, 2) = vbLf & target.Range("a3").Offset(x - 1, 0)
        Else
            .Offset(y, 2) = target.Range("a3").Offset(x - 1, 0)
        End If
        y = y + 2
    Next x
    .Offset(5, 4) = "X1H"
    .Offset(5, 5) = .Offset(buf + 2, 0).Address & ":" & .Offset(y - 2, 0).Address
    .Offset(5, 6) = .Offset(buf + 2, 1).Address & ":" & .Offset(y - 2, 1).Address
    .Offset(5, 7) = .Offset(buf + 2, 2).Address & ":" & .Offset(y - 2, 2).Address

End With ' xyList

End Sub

Private Sub PUT_SERIES(ByVal target As Variant)
' TYPE1グラフにパーツを追加してTYPE2グラフに加工

Dim y As Long ' Counter

' 第2軸ラベルタイトルの修正
ActiveSheet.ChartObjects(1).Chart.Axes(xlValue, xlSecondary).AxisTitle.Text = _
    "累積比率%"

Dim upper As Long
upper = setUpper(False)

Dim rgbArray ' RGBcolor
rgbArray = Split(expression:=AxisColorRGB, delimiter:=",")

' 系列を追加
For y = 1 To upper
    With ActiveSheet.ChartObjects(1).Chart.SeriesCollection.NewSeries
        .ChartType = xlXYScatterLinesNoMarkers
        .AxisGroup = xlSecondary
        .XValues = Range(Range("m1").Offset(y - 1, 1))
        .Values = Range(Range("m1").Offset(y - 1, 2))
        .Name = Range("m1").Offset(y - 1, 0)
        .Border.Color = RGB(rgbArray(0), rgbArray(1), rgbArray(2)) ' 線色
        .Format.Line.Weight = AxisLineWeight 'pt, 線幅
    End With
Next y

' データラベルを追加
Dim str As String
upper = setUpper(True)
With ActiveSheet.ChartObjects(1).Chart
    For y = 4 To upper Step 2
        .SeriesCollection(y).HasDataLabels = True
        str = "='" & ActiveSheet.Name & "'!" & Range("m1").Offset(y - 3, 3)
        With .SeriesCollection(y).DataLabels
            .Format.TextFrame2.TextRange. _
                InsertChartField msoChartFieldRange, str, 0
            .ShowValue = False
            .ShowRange = True
            .Format.TextFrame2.WordWrap = msoFalse
        End With
    Next y
    With .SeriesCollection(4) ' N数
        If N_OnYAxis Then
            .DataLabels.Position = xlLabelPositionLeft
        Else
            .DataLabels.Position = xlLabelPositionCenter
        End If
        If ModChecker(TotalRef(target), Y1IntRef(target)) = 0 And N_OnYAxis = True Then
            .HasDataLabels = False
        End If
    End With
End With

' 軸の線,ラベルなし
With ActiveSheet.ChartObjects(1).Chart
    .Axes(xlValue).MajorUnit = Y1IntRef(target) '第1縦軸のスケール合わせ
    .Axes(xlValue).Format.Line.Visible = msoFalse
    .Axes(xlValue, xlSecondary).Format.Line.Visible = msoFalse
    .Axes(xlCategory).Format.Line.Visible = msoFalse
    .Axes(xlValue, xlSecondary).TickLabelPosition = xlNone
    If UnevenDataLabels Then ' X軸段違いラベルの処理
        .SeriesCollection(8).DataLabels.Position = xlLabelPositionBelow
        .Axes(xlCategory).TickLabelPosition = xlNone
    End If
End With

End Sub

Private Function setUpper(ByVal u As Boolean) As Long
Dim myArray
myArray = Array(6, 5, 8, 6)
If u = False Then
    If UnevenDataLabels Then
        setUpper = myArray(1)
    Else
        setUpper = myArray(2)
    End If
Else
    If UnevenDataLabels Then
        setUpper = myArray(3)
    Else
        setUpper = myArray(4)
    End If
End If
End Function

Private Function ModChecker(ByVal t, ByVal i)
    ModChecker = t - i * Int(t / i)
End Function

Private Function TotalRef(ByVal t) As Double
    TotalRef = t.Range("b3").End(xlDown)
End Function

Private Function Y1IntRef(ByVal t) As Double
    Y1IntRef = t.Range("b3").End(xlDown).Offset(3, 0)
End Function

Private Function Y2IntRef(ByVal t) As Double
    Y2IntRef = t.Range("b3").End(xlDown).Offset(4, 0)
End Function

Private Sub ERR_MSG1()
    MsgBox "Y1軸目盛間隔が不適です。"
End Sub

Private Sub ERR_MSG2()
    MsgBox "Y2軸目盛間隔が不適です。"
End Sub

Private Sub ERR_MSG3()
    MsgBox "項目が多すぎます。"
End Sub

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

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

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

TYPE 1｜データ範囲を指定する

晴花

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

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

TYPE 1｜マクロを実行する

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

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

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

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

下のようなパレート図をあたらしいシートにアウトプットします。

ここにデフォルトの縦軸ラベル名の修正やグラフ・プロットエリアのサイズ変更，さらにはデータラベルの位置など適宜任意の加工をくわえます。

TYPE 1｜パラメータ

TYPE 1図には，コードの先頭に次のようなパラメータを用意してあります。

  • LineMarkers
  • DatalabelsOnBars
  • DatalabelsOnLine
  • BarColorRGB
  • LineColorRGB

それぞれ順に，

  • 線グラフの上にマーカーを表示するか
  • 棒グラフの上に(件数の)データラベルを表示するか
  • 線グラフの上に(累積比率の)データラベルを表示するか
  • 棒グラフのRGBカラー
  • 線グラフのRGBカラー

をコントロールします。具体的には，順に

  • true: する, false: しない
  • true: する, false: しない
  • true: する, false: しない
  • 任意のRGB値を指定(cf.カラーピッカー)
  • 任意のRGB値を指定

をコードの当該部分を書き換えて指定し, 　7 から再実行して反映させます。

この時点でシートの上に出力された，下図ハイライトの部分については，過剰でも過少でもない目盛間隔を探る意味で，「目盛間隔の目安」を計算(第1縦軸のみ；第2縦軸は固定値)しています。TYPE 1図ではこの値をグラフに強制していないので，この値を適用する場合には，別途手作業で設定します。

アルゴリズムの引用元: Webサイト『イメージングソリューション』記事「【C#】グラフのメモリ間隔の計算」


TYPE 1が目的の場合，以上で完了です。

TYPE 2｜目盛間隔を決める

TYPE 1で出力された「目盛間隔の目安」は，TYPE 2では一転厳格に反映していきます。

したがってTYPE 2を実行する前に，あらかじめ提示された値を拒否したい場合については，第1縦軸(「Y1軸」)あるいは第2縦軸(「Y2軸」)の目盛間隔を任意の値に必ず書きかえておきます。

TYPE 2｜マクロを実行する

先と同様マクロダイアログを開き，今度はPARETO_FOR_QC_TYPE2の方を選択して，実行ボタンをクリックします。

これにより，TYPE 1図が次のようにTYPE 2図に描き変わります。

仕様上，第2縦軸側のラベルが軸目盛と被ってしまうので，プロットエリア(黄)の右中央のハンドル(赤)を左にいくらかドラッグし，スペースを確保したうえで，

軸ラベルのみを右方に戻して，パーツの被りを修正します。

TYPE 2｜パラメータ

TYPE 2図には，次のようなパラメータが存在します。

  • N_OnYAxis
  • AxisColorRGB
  • AxisLineWeight
  • UnevenDataLabels

それぞれ順に，

  • 【第1縦軸】件数合計を目盛りと一体化
  • 【第1縦軸，第2縦軸】RGBカラー
  • 【第1縦軸，第2縦軸】太さ(pt)
  • 【横軸】段違いラベル

をコントロールします。具体的には，順に

  • true: する, false: しない
  • 任意のRGB値を指定
  • 任意のサイズを指定
  • true: する, false: しない

をコードの当該部分を書き換えて指定し，　7 から再実行して反映させます。

なお，横軸の段違いラベルをtrueにした場合，プロットエリアを操作して第2縦軸ラベルと同様の空間確保が必要になります。

最後にTYPE 2の場合，シート上の「目盛線の長さ」を加減してグラフに即時反映させることができます。この値は，グラフの棒x本分相当の横幅と同じ長さであることを意味します(0≤x≤項目の数)。