【エクセルマクロ】グループごとに連番を振る：自動化

Sub 項目ごとに連番をつける()

Dim i As Long
Dim j As Long
Dim Cnt As Long
Dim LastRow As Long
Dim GetName As String

    '最終行を取得
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False

    '2行目~最終行までループ
    For i = 2 To LastRow

        '連番用
        Cnt = 1

        'B列の「グループ」を変数格納
        GetName = Cells(i, 2)

        '2行目~最終行までループ
        For j = 2 To LastRow
            If Cells(j, 2) = GetName Then

                '同じグループに連続した番号入力
                Cells(j, 3) = Cnt
                Cnt = Cnt + 1

            End If
        Next j
    Next i

    Application.ScreenUpdating = True

End Sub