'コントロールブレーク処理のサンプルマクロ1

'以下の表のキー項目1、2、3毎の、データ項目1の最大値とデータ項目2の
'合計を、新規シートへ出力するサンプルです。
'Sheet1に以下の構成の表を作成し、ControlBreakTest1マクロを実行してください。


'Sheet1
'
'    |     A     |     B     |     C     |      D      |      E      |
' ---+-----------+-----------+-----------+-------------+-------------+
'  1 | キー項目1 | キー項目2 | キー項目3 | データ項目1 | データ項目2 |
'  2 |     10001 |     20001 |         1 |          92 |          65 |
'  3 |     10001 |     20001 |         1 |           6 |          48 |
'  4 |     10001 |     20001 |         2 |          91 |          42 |
'  5 |     10001 |     20001 |         2 |          64 |          27 |
'  6 |     10001 |     20002 |         1 |          24 |          68 |
'  7 |     10001 |     20002 |         1 |          44 |          37 |
'  8 |     10002 |     20002 |         1 |          69 |          32 |
'  9 |     10002 |     20002 |         1 |          84 |          44 |
' 10 |     10002 |     20002 |         2 |          87 |          82 |
' 11 |     10002 |     20003 |         2 |          49 |          38 |
' 12 |     10002 |     20003 |         2 |          66 |          86 |

Option Explicit
Option Base 0

Const mySum = 1
Const myCount = 2
Const myMax = 3
Const myMin = 4
Const myFirst = 5
Const keyNoFieldName = "集計レベル"

Sub ControlBreakTest1()
    Dim range1 As Range, range2 As Range
    Dim keyFieldNo As Variant
    Dim sumFieldNo As Variant

    '並べ替え
    With Sheets("Sheet1")
        .Cells(1, 1).CurrentRegion.SortSpecial _
            SortMethod:=xlCodePage, _
            Key1:=.Cells(2, 1), Order1:=xlAscending, _
            Key2:=.Cells(2, 2), Order2:=xlAscending, _
            Key3:=.Cells(2, 3), Order3:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    'リスト範囲の設定
    Set range1 = Sheets("Sheet1").Cells(1, 1).CurrentRegion
    If range1.Rows.Count <= 1 Then Exit Sub
    Set range1 = range1.Resize(range1.Rows.Count - 1).Offset(1)

    '出力セル位置の設定
    Set range2 = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(2, 1)

    'フィールド情報の作成
    keyFieldNo = Array(1, 2, 3)
    sumFieldNo = Array(Array(4, myMax), Array(5, mySum))

    '集計処理の実行
    MyControlBreak1 range1, range2, keyFieldNo, sumFieldNo
End Sub

Sub MyControlBreak1(range1 As Range, range2 As Range, _
        keyFieldNo As Variant, sumFieldNo As Variant)

    Dim outputRange As Range, r As Range
    Dim i As Integer, j As Integer
    Dim v As Variant
    Dim keyFieldCount As Integer, sumFieldCount As Integer
    Dim ifBreak() As Boolean
    Dim key() As Variant
    Dim key0() As Variant
    Dim sum1() As Variant
    Dim keyColumn As Integer

    Application.ScreenUpdating = False

    'キー値配列と集計値配列の定義
    keyFieldCount = UBound(keyFieldNo)
    sumFieldCount = UBound(sumFieldNo)
    ReDim ifBreak(0 To keyFieldCount)
    ReDim key(0 To keyFieldCount)
    ReDim key0(0 To keyFieldCount)
    ReDim sum1(-1 To keyFieldCount, 0 To sumFieldCount)

    '集計レベル番号の列番号を設定
    keyColumn = range1.Columns.Count + 1

    '出力シートの項目見出しの作成
    For i = 1 To range1.Columns.Count
        range2.Cells(0, i).Value = range1.Cells(0, i).Value
    Next
    range2.Cells(0, range1.Columns.Count + 1).Value = keyNoFieldName

    '出力セル範囲の初期化
    Set outputRange = range2

    '前キー値設定
    For i = 0 To keyFieldCount
        key0(i) = range1.Cells(1, keyFieldNo(i))
    Next

    '合計値初期化
    For i = -1 To keyFieldCount
        For j = 0 To sumFieldCount
            Select Case sumFieldNo(j)(1)
                Case mySum, myCount
                    sum1(i, j) = 0
                Case myMax, myMin, myFirst
                    sum1(i, j) = range1.Cells(1, sumFieldNo(j)(0)).Value
            End Select
        Next
    Next

    For Each r In range1.Rows

        'キー値設定
        For i = 0 To keyFieldCount
            key(i) = r.Cells(1, keyFieldNo(i))
        Next

        'ブレークフラグ初期化
        For i = 0 To keyFieldCount
            ifBreak(i) = False
        Next

        'ブレークフラグ設定
        For i = 0 To keyFieldCount
            If key(i) <> key0(i) Then
                For j = i To keyFieldCount
                    ifBreak(j) = True
                Next
                Exit For
            End If
        Next

        'ブレーク時処理
        For i = keyFieldCount To 0 Step -1
            If ifBreak(i) Then

                'キー値出力設定
                For j = 0 To i
                    outputRange.Cells(1, keyFieldNo(j)).Value = key0(j)
                Next

                'キーNo出力設定
                outputRange.Cells(1, keyColumn).Value = i + 1

                For j = 0 To sumFieldCount

                    '合計値出力設定
                    outputRange.Cells(1, sumFieldNo(j)(0)).Value = sum1(i, j)

                    '合計値初期化
                    Select Case sumFieldNo(j)(1)
                        Case mySum, myCount
                            sum1(i, j) = 0
                        Case myMax, myMin, myFirst
                            sum1(i, j) = r.Cells(1, sumFieldNo(j)(0)).Value
                    End Select
                Next

                '前キー値更新
                key0(i) = key(i)

                'レコード出力、移動
                Set outputRange = outputRange.Offset(1)
            End If
        Next

        '合計値加算
        For i = -1 To keyFieldCount
            For j = 0 To sumFieldCount
                v = r.Cells(1, sumFieldNo(j)(0)).Value
                Select Case sumFieldNo(j)(1)
                    Case mySum
                        sum1(i, j) = sum1(i, j) + v
                    Case myCount
                        sum1(i, j) = sum1(i, j) + 1
                    Case myMax
                        If sum1(i, j) < v Then sum1(i, j) = v
                    Case myMin
                        If sum1(i, j) > v Then sum1(i, j) = v
                    Case myFirst
                End Select
            Next
        Next
        'Application.StatusBar = r.Row
    Next

    '最終レコードブレーク処理
    For i = keyFieldCount To 0 Step -1
        For j = 0 To i
            outputRange.Cells(1, keyFieldNo(j)).Value = key0(j)
        Next
        outputRange.Cells(1, keyColumn).Value = i + 1
        For j = 0 To sumFieldCount
            outputRange.Cells(1, sumFieldNo(j)(0)).Value = sum1(i, j)
        Next
        Set outputRange = outputRange.Offset(1)
    Next

    '総合計値出力
    For i = 0 To sumFieldCount
        outputRange.Cells(1, sumFieldNo(i)(0)).Value = sum1(-1, i)
    Next
    outputRange.Cells(1, keyColumn).Value = 0

    'Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub