CalculateSubtotals

' CalculateSubtotals
' -----------------
' Macro Name: CalculateSubtotals
' Description: A列のグループごとにB列の値の小計を計算して新しいシートに出力します
' Parameters: なし
' Returns: なし
' Usage: A列にグループ名、B列に数値があるシートで CalculateSubtotals を実行します
' -----------------

Sub CalculateSubtotals()
    On Error GoTo ErrorHandler

    Dim ws As Worksheet
    Dim destWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim groupKey As String
    Dim subtotals As Object
    Dim k As Variant
    Dim destRow As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    If lastRow < 2 Then
        MsgBox "データが見つかりません（A列: グループ名、B列: 数値）", vbCritical, "エラー"
        Exit Sub
    End If

    Set subtotals = CreateObject("Scripting.Dictionary")

    For i = 2 To lastRow
        groupKey = CStr(ws.Cells(i, 1).Value)
        If groupKey <> "" Then
            If subtotals.Exists(groupKey) Then
                subtotals(groupKey) = subtotals(groupKey) + ws.Cells(i, 2).Value
            Else
                subtotals.Add groupKey, ws.Cells(i, 2).Value
            End If
        End If
    Next i

    Set destWs = Worksheets.Add
    destWs.Name = "小計_" & Format(Now, "hhmmss")
    destWs.Cells(1, 1).Value = "グループ"
    destWs.Cells(1, 2).Value = "小計"

    destRow = 2
    For Each k In subtotals.Keys
        destWs.Cells(destRow, 1).Value = k
        destWs.Cells(destRow, 2).Value = subtotals(k)
        destRow = destRow + 1
    Next k

    MsgBox subtotals.Count & " グループの小計を計算しました", vbInformation, "完了"

    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました:" & vbCrLf & Err.Description, vbCritical, "エラー"
End Sub