Sub 小計集計書込みグループ化進捗表示付き() Dim 入力File As String Dim 入力Tab As String Dim myRange As AutoFilter Dim RowMin As Long Dim RowMax As Long Dim J As Long Dim JJ As Long Const MaxBar As Integer = 26 Dim ws As Worksheet Dim flag As Boolean Dim 合計コード As Integer Dim 小計コード As Integer Dim 小計A As Double Dim 小計B As Double Dim 合計A As Double Dim 合計B As Double Dim 値A列 As Integer Dim 値B列 As Integer Dim 小計キー列 As Integer Dim 合計キー列 As Integer Dim 小計キー列文字 As String Dim 合計キー列文字 As String Dim 列Max As String Dim GroupStart As Long Dim TopGroupStart As Long Dim GroupEnd As Long Dim TopGroupEnd As Long Dim 合計キーセル As Variant Dim 小計キーセル As Variant 入力ファイル = "小計合計サンプル.xlsx" 入力Tab = "月別売上原価" 値A列 = 3 '集計する値A列番号 値B列 = 4 '集計する値B列番号 小計キー列 = 2 '小計キー列番号 合計キー列 = 1 '合計キー列番号 小計キー列文字 = "B" '小計キー列名 合計キー列文字 = "A" '合計キー列名 RowMin = 2 列Max = "I" 'Application.ScreenUpdating = False UserForm111.Caption = "月別、品目別集計" 'ユーザフォームの初期化 UserForm111.Label2.Caption = "" '表示クリア UserForm111.Show vbModeless Windows(入力ファイル).Activate Sheets(入力Tab).Select '入力Fileの最大行検出 RowMax = Cells(Rows.Count, 1).End(xlUp).Row 'ユーザフォームの初期化 UserForm111.ProgressBar1.Min = 0 UserForm111.ProgressBar1.Max = MaxBar UserForm111.Label1.Caption = 入力Tab & "データ ソート" UserForm111.ProgressBar1.Value = 0 UserForm111.Repaint '合計(C)_小計(A)をキーに昇順ソート ActiveWorkbook.Worksheets(入力Tab).Sort.SortFields.Clear ActiveWorkbook.Worksheets(入力Tab).Sort.SortFields.Add Key:=Range( _ 合計キー列文字 & RowMin & ":" & 合計キー列文字 & RowMax), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets(入力Tab).Sort.SortFields.Add Key:=Range( _ 小計キー列文字 & RowMin & ":" & 小計キー列文字 & RowMax), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets(入力Tab).Sort .SetRange Range("A1:" & 列Max & RowMax) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'データを順に読みながら排出地、種類コードごとの集計を書込む 小計A = 0 小計B = 0 合計A = 0 合計B = 0 GroupStart = RowMin TopGroupStart = RowMin J = 1 'A列値、B列値を読んで、小計、合計に加算 Do While J <= RowMax J = J + 1 小計キーセル = Cells(J, 小計キー列).Value 合計キーセル = Cells(J, 合計キー列).Value 小計A = 小計A + Cells(J, 値A列).Value 小計B = 小計B + Cells(J, 値B列).Value 合計A = 合計A + Cells(J, 値A列).Value 合計B = 合計B + Cells(J, 値B列).Value If 小計キーセル <> Cells(J + 1, 小計キー列).Value Or J = RowMax Then '次のレコードで小計種類が変わる 小計種類グループを終了し、1行追加して小計を書込む GroupEnd = J Rows(J + 1).Select Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove Cells(J + 1, 小計キー列).Value = 小計キーセル Cells(J + 1, 小計キー列 + 1).Value = Cells(J, 小計キー列 + 1).Value & " 小計" Cells(J + 1, 値A列).Value = 小計A Cells(J + 1, 値B列).Value = 小計B 'ここまでをグループ化(レベル2) Rows(GroupStart & ":" & GroupEnd).Select Selection.Rows.Group ActiveSheet.Outline.ShowLevels RowLevels:=1 小計A = 0 小計B = 0 RowMax = RowMax + 1 J = J + 1 GroupStart = J + 1 End If If 合計キーセル <> Cells(J + 1, 合計キー列).Value Or J = RowMax Then '次のレコードで合計種類が変わる 合計種類グループを終了し、1行追加して小計を書込む If 小計A <> 0 Then '直前に小計種類の区切りが来ていない(次の集計種類の小計種類と現レコードの小計種類が同じ) 'まず小計種類の区切りを付ける GroupEnd = J Rows(J + 1).Select Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove Cells(J + 1, 小計キー列).Value = 小計キーセル & " 小計" Cells(J + 1, 値A列).Value = 小計A Cells(J + 1, 値B列).Value = 小計B 'ここまでをグループ化(レベル1) Rows(GroupStart & ":" & GroupEnd).Select Selection.Rows.Group ActiveSheet.Outline.ShowLevels RowLevels:=1 小計A = 0 小計B = 0 RowMax = RowMax + 1 J = J + 1 End If '合計種類の区切りをつける 1行追加して合計を書込む TopGroupEnd = J Rows(J + 1).Select Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove Cells(J + 1, 合計キー列).Value = 合計キーセル Cells(J + 1, 小計キー列).Value = "合計" Cells(J + 1, 値A列).Value = 合計A Cells(J + 1, 値B列).Value = 合計B Rows(TopGroupStart & ":" & TopGroupEnd).Select Selection.Rows.Group ActiveSheet.Outline.ShowLevels RowLevels:=1 合計A = 0 合計B = 0 RowMax = RowMax + 1 J = J + 1 GroupStart = J + 1 TopGroupStart = GroupStart End If 'プログレスバーの値更新 JJ = J - 1 UserForm111.Label2.Caption = JJ UserForm111.ProgressBar1.Value = (MaxBar * JJ) / RowMax UserForm111.Repaint '再表示 Loop Unload UserForm111 'ユーザフォームの終了 MsgBox "小計、合計処理を終了しました。" Application.ScreenUpdating = True Exit Sub Errorhandler: End Sub