Excel VBA 種目別に自動採番（複数の種類で連番を取る）

こんにちは。
派犬事務員のコロ子です。

種目別自動採番マクロ

コロ子の会社では毎日、品物が増えるたびに連続の番号を取る作業ある。

A列に複数の種類が入っていて、種類ごとに連番を取る。

【例】下記表で新しく種目CCCが追加になる場合。

B列に66を入力する。

もし
AAAなら：103
BBBなら：22
DDDなら：33

こんな具合に採番をする。手作業なら多分、A列の項目でフィルタをして、B列の最大値に1を足した数値を入力する。
途中で種目が変更になったり、欠番が出たり、B列の最大値が一番下に来ているとは限らない場合があるので地味に面倒な作業だったりする。

こんな作業を毎日やっているならば、マクロを作成しよう。

コピペでできるよ！

作り方

【① A列に入力規則を作成する。】
（プルダウンでデータを選択できるようにする）

A列を選択した状態で、「データ」タブ→「データの入力規則」→「データの入力規則」を選択

入力の種類：「リスト」を選択
元の値：種目を半角カンマ（,）で区切って入力

【② コードをシートモジュールに書く】
対象のシート（ここではSheet1）のシートモジュールを選択する。
オブジェクトボックスで「WorkSheet」、プロシージャーボックスで「Change」を選択する。

コードウィンドウに下記コードを書く
＊Private Sub Worksheet_Change(ByVal Target As Range)はプロシージャーボックスで「Change」を選ぶと自動に表示される。
セルの中身を変更したらこのプロシージャーが呼び出される。

【コード】Worksheet_Changeイベント

Private Sub Worksheet_Change(ByVal Target As Range)

Dim buf As Range

Application.ScreenUpdating = False
Application.EnableEvents = False 'イベント禁止

If Target.Column = 1 Then

    'オートフィルタ
    Range("A1").AutoFilter Field:=1, Criteria1:=Range("A" & Target.Row).Value
     
    'アクティブセル領域の可視範囲を取得
    Set buf = Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeVisible)
     
    '最大値＋1を取得
    Range("B" & Target.Row).Value = Application.WorksheetFunction.Max(buf) + 1
     
    'フィルター条件解除
    ActiveSheet.ShowAllData
    
    'A列に変更がない場合は元の値に戻す
    If Range("A" & Target.Row).Value = Range("AA" & Target.Row).Value Then
    
        Range("B" & Target.Row).Value = Range("BB" & Target.Row).Value
    
    End If
    
    'AA列、BB列に仮置き
    Range("AA:BB").Clear
    Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
    Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value
       
End If

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

同様にプロシージャーボックスで「SelectionChange」を選択し、下記のコードを書く。
（登録済みのA列を編集状態にして、変更しないでEnter押した場合、値が変更されるのを防ぐため）
【コード】Worksheet_SelectionChangeイベント

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column = 1 And Target.Row >= 2 Then

    'AA列、BB列に仮置き
    Range("AA:BB").Clear
    Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
    Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value

End If

End Sub

＊空腹おやじ(id:Z1000S)さんよりご指摘頂いて修正しました。
詳しくは次の記事で。

完成！

例えば、A列に日付、B列に種目、C列に番号の表の場合、コードの

”A”→”B”
”B”→”C”
”A1”→”B1”
4行目のTarget.Column = 1　→　Target.Column = 2（数字は列の番号）

に変更すればOK！
こんな作業のある人は自分の表に合わせて作ってみよう！

このマクロ、VBAを始めたての頃に「マクロの自動記録」で作成した。
もちろんそのままでは使えないから、上手くいかないところを無理やり手で直して、何がなんだか分からないけど、とりあえず希望の結果になるからOKという作り方だった。
それから毎日このマクロを使っていて、特に問題ないからずっとそのままにしてたけど、最近見直したら、あまりにもヒドイ驚きのコードだったので作り直すことにした。マクロの自動記録をベースにしてるからコードがやたらと長くて意味不明の個所がいっぱいあった。

そんなデタラメでも、出来た時は感動したし、すごく便利で重宝しているから、下手でも力ずくでも作って良かっな、って思う。そして、その時の感動が「VBAでもっといろいろできるようになりたい！」という気持ちの源だったんだな、と実感。