元データ

新しいブックの任意のシートに、項目・件数・累積比率の3列からなる表を用意します。見出し行は3列とも必須です（内容は問いません）。最下行に合計行がある場合は、選択範囲に含めません。

02

VBE を起動する

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

VBE が起動します。メニューの挿入 → 標準モジュールをクリックすると、コードウィンドウが表示されます。

03

コードをコピペする

下のコードをすべてコピーし、コードウィンドウに貼り付けます。


Option Explicit
Option Base 1

'===============================================================================
' パレート図 作成マクロ
' サイト : hitorimarketing.net/tools/vba/paretograph-macro.html
' 作成者 : hawcas
' 作成年 : 2014, 2016, 2020
'===============================================================================
'
' 【概要】
'   QC（品質管理）用のパレート図を2段階で生成するマクロ。
'   TYPE1 で基本グラフを作成し、TYPE2 でカスタム軸・ラベルを追加して仕上げる。
'
' 【使い方】
'   1. 元データシートで「項目列・件数列・累積比率列」の3列を選択する。
'   2. PARETO_FOR_QC_TYPE1 を実行 → 新規シートにグラフが生成される。
'   3. 生成されたシートで目盛間隔を確認・調整してから
'      PARETO_FOR_QC_TYPE2 を実行 → グラフが TYPE2 仕様に仕上がる。
'
' 【TYPE1 シートのセルレイアウト（生成後）】
'   A〜C列 : 転記された元データ（2行目に0値を挿入済み）
'   A/B の 計行以降 : 件数合計・目盛間隔の目安・目盛線の長さ
'
' 【TYPE2 で使用する座標リスト（E〜P列）】
'   E列（xyList=E1 基点）: Y1V（Y1軸縦線）・Y1MAX（Y1軸最大値ラベル）の座標
'   I列（xyList=I1 基点）: Y1H・Y2V・Y2H・X1H の各パーツ座標と系列参照テーブル
'   M列（M1 基点）       : PUT_SERIES が参照する系列名・X範囲・Y範囲・ラベル の一覧
'
' 【エラー一覧】
'   ERR_MSG1 : Y1 軸目盛間隔が件数合計を超えている（不適）
'   ERR_MSG2 : Y2 軸目盛間隔が 100% を整数分割できない（不適）
'   ERR_MSG3 : 項目数が上限（31行）を超えている
'
' 【モジュール構成】
'   Public Sub
'     PARETO_FOR_QC_TYPE1   TYPE1 グラフの生成
'     PARETO_FOR_QC_TYPE2   TYPE2 グラフへの変換（PUT_HEADERS → PUT_SERIES を順に呼ぶ）
'
'   Private Sub / Function（内部ユーティリティ）
'     PUT_LINE_MARKERS      累積比率線にマーカーを付置
'     PUT_HEADERS           TYPE2 用の座標リストを E〜P 列に書き出す
'     PUT_SERIES            座標リストを参照して系列・ラベル・軸を追加・調整する
'     setUpper              UnevenDataLabels の設定に応じて系列追加上限を返す
'     ModChecker            剰余の計算（VBA の Mod が浮動小数で不正確なため代替）
'     TotalRef              target から件数合計セルの値を返す
'     Y1IntRef              target から Y1 軸目盛間隔セルの値を返す
'     Y2IntRef              target から Y2 軸目盛間隔セルの値を返す
'     ERR_MSG1〜ERR_MSG3    エラーメッセージ表示
'===============================================================================


'-------------------------------------------------------------------------------
' TYPE1 パラメータ定数
'   グラフの見た目を変更する場合はここを編集する
'-------------------------------------------------------------------------------
Const LineMarkers      As Boolean = True          ' 累積比率線に四角形マーカーを表示するか
Const DatalabelsOnBars As Boolean = True          ' 棒グラフの上にデータラベルを表示するか
Const DatalabelsOnLine As Boolean = True          ' 累積比率線の上にデータラベルを表示するか
Const BarColorRGB      As String  = "42,42,42"   ' 棒グラフの色（RGB カンマ区切り）
Const LineColorRGB     As String  = "153,153,153" ' 累積比率線の色（RGB カンマ区切り）

'-------------------------------------------------------------------------------
' TYPE2 パラメータ定数
'   グラフの見た目・ラベル配置を変更する場合はここを編集する
'-------------------------------------------------------------------------------
Const N_OnYAxis        As Boolean = False         ' N数を Y1軸頂上の目盛として表示するか
                                                  '   False の場合はグラフ左上角に "N=xx" で表示
Const AxisColorRGB     As String  = "120,120,120" ' Y1・Y2 軸線の色（RGB カンマ区切り）
Const AxisLineWeight   As Double  = 0.5           ' Y1・Y2 軸線の太さ（pt）
Const UnevenDataLabels As Boolean = False         ' X軸ラベルを段違いに表示するか


'===============================================================================
' Sub : PARETO_FOR_QC_TYPE1
' 概要 : TYPE1 パレート図の生成。
'        選択した3列データを新規シートに転記し、集合縦棒グラフを生成した後、
'        累積比率系列を第2軸の散布図に変換して軸・色・ラベルを設定する。
'        最後に TYPE2 用の目盛間隔目安・目盛線長さをシートに書き出す。
' 前提 : 元データシートで「項目列・件数列・累積比率列」の3列（複数行）を選択してから実行。
'        項目数は最大 31 行まで。
' 出力 : 元シートの右隣に新規シートを追加し、グラフと補助情報を配置する。
'===============================================================================
Sub PARETO_FOR_QC_TYPE1()

Application.ScreenUpdating = False

Dim x As Long, y As Long, z As Long ' ループカウンタ

Dim target ' 選択範囲オブジェクト
Set target = Selection

'--- 新規シートを元シートの右隣に挿入し、選択データを A〜C 列に転記する ---
Dim sheetName As String
sheetName = ActiveSheet.Name
Worksheets.Add after:=Worksheets(sheetName)

sheetName = ActiveSheet.Name
z = target.Rows.Count
If z > 31 Then ' 項目数の上限チェック（31行を超えるとエラー）
    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値行を挿入する ---
'   累積比率線を X=1, Y=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 ' グラフオブジェクトのインデックス番号
idx = ActiveChart.Parent.Index

With ActiveSheet.ChartObjects(idx).Chart

    '--- 累積比率系列（系列2）を第2軸の散布図に変換 ---
    With .SeriesCollection(2)
        If LineMarkers Then
            Call PUT_LINE_MARKERS(z - 2) ' マーカー付き散布図（定数で制御）
        Else
            .ChartType = xlXYScatterLinesNoMarkers ' マーカーなし散布図
        End If
        .AxisGroup = 2 ' 第2軸（右縦軸）に関連付け
    End With

    '--- 件数系列（系列1）のデータソース定義式を再構成する ---
    '   0値挿入行を除いた実データ行のみを参照するよう SERIES 式を書き直す
    Dim formulaStrings As String ' 系列の SERIES 定義式
    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

    '--- 件数の合計行をデータ表の直下に追加する（目盛間隔計算・TYPE2 参照に使用）---
    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横軸（X 軸）の設定 ---
    With .Axes(xlCategory)
        .TickLabelSpacing = 1   ' 全項目のラベルを表示
        .MajorTickMark    = xlNone
        '.TickLabels.Orientation = xlUpward ' ラベルを縦書きにする場合はコメント解除
    End With

    '--- 第2横軸の設定（散布図の X 軸; 非表示）---
    With .Axes(xlCategory, xlSecondary)
        .MajorTickMark     = xlNone
        .TickLabelPosition = xlNone
        .Format.Line.Visible = msoFalse
        .MinimumScale = 1
        .MaximumScale = z - 1 ' 0値行を除いた項目数
    End With

    '--- 第1縦軸（Y1 軸; 件数）の設定 ---
    .ChartGroups(1).GapWidth = 0 ' 棒の間隔をゼロ（パレート図の慣例）
    With .Axes(xlValue)
        .MinimumScale = 0
        .MaximumScale = totalNumber
        .MajorTickMark = xlInside
        .HasTitle = True
        .AxisTitle.Text = "件数"
        '.AxisTitle.Orientation = xlVertical ' 軸タイトルを縦書きにする場合はコメント解除
    End With

    '--- 第2縦軸（Y2 軸; 累積比率）の設定 ---
    .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

    '--- 棒グラフの色（定数 BarColorRGB を RGB に変換して適用）---
    Dim rgbArray ' RGB 値の一時配列
    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

    '--- 累積比率線の色（定数 LineColorRGB を RGB に変換して適用）---
    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 ' 凡例を削除

    '--- 棒グラフ上のデータラベル（定数 DatalabelsOnBars で制御）---
    If DatalabelsOnBars Then
        .SeriesCollection(1).HasDataLabels = True
    End If

    '--- 累積比率線上のデータラベル（定数 DatalabelsOnLine で制御）---
    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% ラベルを非表示
            ' 最初の棒と累積比率ラベルが重なる場合は 2 点目のラベルを右に避ける
            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 用の補助情報をシートに書き出す
'   目盛間隔の目安（Y1・Y2）と目盛線の長さを表の直下に配置する。
'   アルゴリズム出典: imagingsolution.net/program/autocalcgraphstep/
'===========================================================================
Cells(y + 3, 1) = "目盛間隔の目安"
Cells(y + 4, 1) = "Y1軸"
Cells(y + 5, 1) = "Y2軸"

Dim exponent    As Double ' 桁スケール（10^N）
Dim significand As Double ' 仮数（totalNumber / exponent）
Dim y1Interval  As Double ' Y1 軸の推奨目盛間隔
Const y2Interval As Double = 0.2 ' Y2 軸の固定目盛間隔

'--- totalNumber の桁数に応じた exponent を計算（Excel 2010 は Floor_Math 非対応のため分岐）---
If CInt(Application.Version) = 14 Then ' Excel 2010
    exponent = Application.WorksheetFunction.Power(10, _
        Int(Application.WorksheetFunction.Log10(totalNumber))) ' Floor_Math の代替として Int を使用
Else ' Excel 2013 以降
    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 ' TYPE2 のカスタム軸目盛線長さの初期値

Application.ScreenUpdating = True

End Sub


'===============================================================================
' Sub : PARETO_FOR_QC_TYPE2
' 概要 : TYPE1 グラフを TYPE2 仕様に変換する。
'        座標リスト（PUT_HEADERS）を E〜P 列に生成し、
'        それを参照してカスタム軸・ラベル系列を追加（PUT_SERIES）する。
' 前提 : PARETO_FOR_QC_TYPE1 で生成したシートがアクティブであること。
'        シート上の目盛間隔の目安（Y1・Y2）を確認・必要に応じ修正済みであること。
'===============================================================================
Sub PARETO_FOR_QC_TYPE2()

Application.ScreenUpdating = False

Dim target
Set target = Range("a1").CurrentRegion
Range("e:p").Clear ' 前回実行分の座標リストをクリア（再実行に対応）

Call PUT_HEADERS(target) ' 座標リストの生成
Call PUT_SERIES(target)  ' 系列・ラベル・軸の追加

Application.ScreenUpdating = True

End Sub


'===============================================================================
' Sub : PUT_LINE_MARKERS  [Private]
' 概要 : TYPE1 グラフの累積比率線（系列2）に四角形マーカーを付置する。
'        最初と最後の点（0% と 100%）のマーカー塗りつぶしは削除する。
' 引数 : size - マーカーを付置する点の総数（= 項目数; 最初・最後を含む）
'===============================================================================
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                  ' 線の太さ（pt）
    .MarkerBackgroundColor = RGB(255, 255, 255) ' マーカー背景色: 白
    .Points(1).MarkerBackgroundColorIndex      = xlNone ' 最初の点（0%）の塗りを削除
    .Points(size + 1).MarkerBackgroundColorIndex = xlNone ' 最後の点（100%）の塗りを削除
End With

End Sub


'===============================================================================
' Sub : PUT_HEADERS  [Private]
' 概要 : TYPE2 グラフ用の座標リストを E〜P 列に書き出す。
'        Y1V・Y1MAX・Y1H・Y2V・Y2H・X1H の6種類のパーツ座標と、
'        PUT_SERIES が参照する系列名・範囲アドレスの参照テーブル（M 列基点）を生成する。
' 引数 : target - A1 の CurrentRegion（A〜C 列の元データ表全体）
'
' 【生成する座標パーツの概要】
'   Y1V  : Y1 軸の縦線本体（X=1 固定, Y: 0〜1）
'   Y1MAX: Y1 軸の最大値ラベル（N 数または "N=xx"）
'   Y1H  : Y1 軸の目盛り横線（各目盛り値ごとに短い横線を散布図系列で表現）
'   Y2V  : Y2 軸の縦線本体（X=項目数+1 固定, Y: 0〜1）
'   Y2H  : Y2 軸の目盛り横線
'   X1H  : X 軸の目盛り横線＋ラベル（項目名; UnevenDataLabels が True の場合は段違い）
'===============================================================================
Private Sub PUT_HEADERS(ByVal target As Variant)

Dim x As Long, y As Long, z As Double ' ループカウンタ

'--- バリデーション ---
If Y1IntRef(target) > TotalRef(target) Then
    Call ERR_MSG1 ' Y1 軸目盛間隔が件数合計を超えている
    Exit Sub
End If
If 100 Mod Y2IntRef(target) * 100 <> 0 Or Y2IntRef(target) * 100 > 100 Then
    Call ERR_MSG2 ' Y2 軸目盛間隔が 100% を整数分割できない
    Exit Sub
End If

'===========================================================================
' E 列（xyList = E1 基点）: Y1V・Y1MAX の座標と参照テーブルを書き出す
'   Y1V  : Y1 軸縦線（X=1 固定, Y: 0〜1 の2点）
'   Y1MAX: Y1 軸最大値ラベル（N_OnYAxis=True なら目盛値, False なら "N=xx" テキスト）
'   参照テーブル（E1:G2 の右 3 列 = H〜J 列相当）: PUT_SERIES から Range("m1") で参照
'===========================================================================
Dim xyList ' 座標リストの基点セル
Set xyList = Range("e1")

With xyList
    ' Y1V: X=1 固定, Y: 0（E3）〜 1（E4）の縦線
    .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

    ' Y1MAX: N 数の表示方法を N_OnYAxis で切り替え
    If N_OnYAxis = True Then
        ' Y1 軸の最大目盛に N 数を数値として表示
        .Offset(7, 0) = 1: .Offset(7, 1) = 1
        .Offset(7, 2) = TotalRef(target)
    Else
        ' グラフ左上角付近に "N=xx" テキストとして表示
        .Offset(7, 0) = 1.5: .Offset(7, 1) = 1
        .Offset(7, 2) = "N=" & TotalRef(target)
    End If

    ' PUT_SERIES が参照する系列範囲の参照テーブル（E1 基点から右 8〜11 列目）
    .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

'===========================================================================
' I 列（xyList = I1 基点）: Y1H・Y2V・Y2H・X1H の座標を書き出す
'===========================================================================
Set xyList = Range("i1")

With xyList

    '--- Y1H: Y1 軸の目盛り横線（各目盛値ごとに2点の横線を描く）---
    .Offset(0, 0) = "Y1H"
    .Offset(1, 0) = "X": .Offset(1, 1) = "Y": .Offset(1, 2) = "Y'"

    ' 目盛り数の上限を計算（合計が目盛間隔で割り切れない場合は1行余分に追加）
    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) ' 上限をクランプ
        ' X 範囲: X=1（Y1 軸左端）〜 X=最大項目番号+1（グラフ右端）
        .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      ' Y 値（件数スケール）
        .Offset(y, 2) = z / TotalRef(target)           ' Y' 値（比率スケール）
        .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 ' 次のパーツ書き出し開始行の基点
    buf = y

    '--- Y2V: Y2 軸の目盛り縦線（X=項目数+1 固定, Y: 各目盛り値）---
    .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 ' 項目の数（0値挿入行と合計行を除いた実データ行数）
    categorySize = target.Rows.Count - 3
    Do While (Y2IntRef(target) * z) * 100 <= 100
        .Offset(y, 0) = categorySize + 1         ' X 座標（Y2 軸の位置）
        .Offset(y, 1) = Y2IntRef(target) * z     ' Y 値（累積比率）
        .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

    '--- Y2H: Y2 軸の目盛り横線（各目盛値ごとに2点の横線を描く）---
    .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 ' 上限（100%）をクランプ
        ' X 範囲: X=目盛線左端（Y1 軸より左）〜 X=項目数+1（Y2 軸位置）
        .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 ' 浮動小数誤差を抑制するため *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

    '--- X1H: X 軸の目盛り横線＋ラベル（項目名）---
    '   UnevenDataLabels=True の場合、偶数番目の項目名に vbLf を前置して段違い表示にする
    .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 ' X 座標（棒の中央）
        .Offset(y, 1) = 0        ' Y 座標（X 軸上）
        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


'===============================================================================
' Sub : PUT_SERIES  [Private]
' 概要 : PUT_HEADERS が生成した座標リストを参照して、
'        TYPE1 グラフにカスタム軸・ラベル系列を追加し、軸表示を整理して TYPE2 に仕上げる。
' 引数 : target - A1 の CurrentRegion
'
' 【系列の追加順と役割】
'   系列 3〜  : PUT_HEADERS の参照テーブル（M 列基点）から順に追加（Y1V, Y1MAX, Y1H, Y2V, Y2H, X1H）
'   データラベル: 偶数インデックスの系列（ラベル用）に対して InsertChartField でセル参照を設定
'===============================================================================
Private Sub PUT_SERIES(ByVal target As Variant)

Dim y As Long ' ループカウンタ

'--- 第2縦軸タイトルを TYPE2 用に変更（"累積比率" → "累積比率%"）---
ActiveSheet.ChartObjects(1).Chart.Axes(xlValue, xlSecondary).AxisTitle.Text = "累積比率%"

Dim upper As Long
upper = setUpper(False) ' 追加する系列数の上限（UnevenDataLabels の設定で変わる）

Dim rgbArray ' RGB 値の一時配列
rgbArray = Split(expression:=AxisColorRGB, delimiter:=",")

'--- 座標リスト（M 列基点）を順に参照して系列を追加する ---
For y = 1 To upper
    With ActiveSheet.ChartObjects(1).Chart.SeriesCollection.NewSeries
        .ChartType  = xlXYScatterLinesNoMarkers
        .AxisGroup  = xlSecondary
        .XValues    = Range(Range("m1").Offset(y - 1, 1)) ' X 範囲のアドレス
        .Values     = Range(Range("m1").Offset(y - 1, 2)) ' Y 範囲のアドレス
        .Name       = Range("m1").Offset(y - 1, 0)        ' 系列名（パーツ名）
        .Border.Color = RGB(rgbArray(0), rgbArray(1), rgbArray(2))
        .Format.Line.Weight = AxisLineWeight
    End With
Next y

'--- 偶数インデックスの系列にデータラベル（セル参照）を追加する ---
'   InsertChartField でラベルをセルの値に連動させる（Excel 2013 以降の機能）
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

    '--- N 数ラベル（系列4）の配置を N_OnYAxis の設定で切り替え ---
    With .SeriesCollection(4)
        If N_OnYAxis Then
            .DataLabels.Position = xlLabelPositionLeft   ' Y1 軸の左側に表示
        Else
            .DataLabels.Position = xlLabelPositionCenter ' グラフ左上角付近に表示
        End If
        ' N 数が Y1 軸の最大目盛と一致し N_OnYAxis=True のとき、ラベルを非表示にして重複を避ける
        If ModChecker(TotalRef(target), Y1IntRef(target)) = 0 And N_OnYAxis = True Then
            .HasDataLabels = False
        End If
    End With
End With

'--- 軸線・ラベルを非表示にし、カスタム軸（series）に置き換える ---
With ActiveSheet.ChartObjects(1).Chart
    .Axes(xlValue).MajorUnit = Y1IntRef(target)             ' Y1 軸スケールを目盛間隔に合わせる
    .Axes(xlValue).Format.Line.Visible            = msoFalse ' Y1 軸線を非表示
    .Axes(xlValue, xlSecondary).Format.Line.Visible = msoFalse ' Y2 軸線を非表示
    .Axes(xlCategory).Format.Line.Visible         = msoFalse ' X 軸線を非表示
    .Axes(xlValue, xlSecondary).TickLabelPosition  = xlNone  ' Y2 軸ラベルを非表示

    '--- UnevenDataLabels=True の場合: X 軸ラベルを非表示にしてカスタムラベル（X1H 系列）を使用 ---
    If UnevenDataLabels Then
        .SeriesCollection(8).DataLabels.Position = xlLabelPositionBelow
        .Axes(xlCategory).TickLabelPosition      = xlNone
    End If
End With

End Sub


'===============================================================================
' Function : setUpper  [Private]
' 概要     : UnevenDataLabels の設定に応じて系列追加数またはラベル追加上限を返す。
'            UnevenDataLabels=False（通常）: 系列6本、ラベル上限インデックス8
'            UnevenDataLabels=True（段違い）: 系列5本、ラベル上限インデックス6
' 引数     : u  False=系列追加数の上限, True=ラベル追加の系列インデックス上限
' 戻り値   : Long
'===============================================================================
Private Function setUpper(ByVal u As Boolean) As Long
Dim myArray
myArray = Array(6, 5, 8, 6) ' (0)通常/系列数, (1)段違い/系列数, (2)通常/ラベル上限, (3)段違い/ラベル上限
If u = False Then
    If UnevenDataLabels Then
        setUpper = myArray(1) ' 段違い: 系列5本
    Else
        setUpper = myArray(2) ' 通常: 系列8本（ラベル上限として使用）
    End If
Else
    If UnevenDataLabels Then
        setUpper = myArray(3) ' 段違い: ラベル上限インデックス6
    Else
        setUpper = myArray(4) ' 通常: ラベル上限インデックス6（myArray(3) と同値）
    End If
End If
End Function


'===============================================================================
' Function : ModChecker  [Private]
' 概要     : 剰余を返す（VBA の Mod 演算子は浮動小数に対して不正確なため、
'            Int を使った計算式で代替する）。
' 引数     : t - 被除数, i - 除数
' 戻り値   : t を i で割った余り
'===============================================================================
Private Function ModChecker(ByVal t, ByVal i)
    ModChecker = t - i * Int(t / i)
End Function


'===============================================================================
' 参照ヘルパー関数群  [Private]
'   target（A1 の CurrentRegion）から特定セルの値を返す。
'   b3.End(xlDown) は件数列の最終データ行（= 件数合計行）を指す。
'===============================================================================

' TotalRef : 件数の合計値を返す（合計行のセル値）
Private Function TotalRef(ByVal t) As Double
    TotalRef = t.Range("b3").End(xlDown)
End Function

' Y1IntRef : Y1 軸目盛間隔を返す（合計行の 3 行下のセル）
Private Function Y1IntRef(ByVal t) As Double
    Y1IntRef = t.Range("b3").End(xlDown).Offset(3, 0)
End Function

' Y2IntRef : Y2 軸目盛間隔を返す（合計行の 4 行下のセル）
Private Function Y2IntRef(ByVal t) As Double
    Y2IntRef = t.Range("b3").End(xlDown).Offset(4, 0)
End Function


'===============================================================================
' エラーメッセージ表示用サブルーチン
'   ERR_MSG1 : Y1 軸目盛間隔が件数合計を超えている
'   ERR_MSG2 : Y2 軸目盛間隔が 100% を整数分割できない
'   ERR_MSG3 : 項目数が上限（31 行）を超えている
'===============================================================================
Private Sub ERR_MSG1()
    MsgBox "Y1軸目盛間隔が不適です。"
End Sub

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

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

コードを貼り付けたら VBE を閉じます。