エクセルVBAで入力番号をつけるやり方を教えてください

質問

品名の種別が10種類ありその種別ごとに行入力するシートがあります。
下記のように種別ごとに入力されると通し番号をつけるマクロを教えてください。IFとMAX関数の組み合わせでやりましたが動きが重たくなるのでマクロで実行したいと思います。通しNo.は3桁　～999位まで入力行は1万行になります。
よろしくお願いします。

入力No. 　　 種別 　　 種別通しNo.
　1 　　　　　　　1 　　　　 1-1
　2 　　　　　　　1 　　　　 1-2
　3 　　　　　　　2 　　　　 2-1
　4 　　　　　　　4 　　　　 4-1
　5 　　　　　　　2 　　　　2-2
　6 　　　　　　　3 　　　　3-1
　7 　　　　　　　4 　　　　 4-2
　8 　　　　　　　1 　　　　 1-3
　：　　　　　　　　：　　　　　　　：

回答No.1

Masa2072 · ベストアンサー

通し番号自体はCOUNTIF関数で
種別をB列、通しNoをC列、1行目が見出し行とすると
=B2 & "-" & COUNTIF(B$2:B2,B2)
という関数で表すことが出来ます。
確かに1万行もあると再計算に時間が掛かりますが、自動再計算をとめてしまう方法もあります。

VBAで行うのであれば、上記式の結果をC列に文字列として入力する処理を上から順番に行いB列値が空になるまで繰り返す

Sub Sample()
　　Sheets("Sheet1").Select
　　Range("B2").Select
　　Do Until Selection.Value = ""
　　　　Selection.Offset(0, 1).Value = Selection.Value & "-" & WorksheetFunction.CountIf(Range(Range("B2"), Selection), Selection.Value)
　　　　Selection.Offset(1, 0).Select
　　Loop
End Sub
という感じになると思います。
C列は予め書式設定で文字列に設定して置いてください。

お礼

素早い回答ありがとうございます。
思ったことができました。

回答No.3

hige_082

＞下記のように種別ごとに入力されると通し番号をつけるマクロを教えてください
とりあえず、「禁止事項」により「丸投げ・依頼」は禁止されています

Ａ列＝入力
Ｂ列＝種別
Ｃ列＝通し

Sub Macro1()
Dim i, ii As Integer
Columns("A:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("A1"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
i = 1
ii = 0
Do Until Cells(i, 2).Value = ""
If ii = 0 Or Cells(i, 2).Value = Cells(i - ii, 2).Value Then
Cells(i, 3).Value = Cells(i, 2).Value & "-" & ii + 1
ii = ii + 1
Else
Cells(i, 3).Value = Cells(i, 2).Value & "-1"
ii = 1
End If
i = i + 1
Loop
Columns("A:C").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub

希望と違ったら、パスして

お礼

ありがとうございます。
禁止事項の件了解してますがVBAは自動マクロ記録から初めて
少し書き込みできるようになったぐらいでサンプルマクロを
動かしながら勉強している状況です。
どこで線引きしていいのかわからず質問してしまいました。
でも初心者の自分にとっては非常に有難いです。

回答No.2

OtenkiAme

こんにちは。

元のデータと通し番号を配列に取り込んで、後から一気に入力されてはどうでしょうか？
種類ごとの通し番号は、計算式を入れてしまうとやはり遅くなってしまうので、
ピボットテーブルの累計を利用してみてください。計算式を入力するより速いと思います。

マクロ処理の大まかな手順は、

元データの種別を配列に取り込む。
作業用のワークシートを作ってピボットテーブルで種別の累計を出す。
配列に取り込んだデータの後ろにピボットテーブルの累計をつなげる。
元データの種別の右に書き込む。
作業用のワークシートを削除する。

です。参考コードは以下のとおりです。

Sub Sample()

　　Dim Sht1 As Worksheet
　　Dim Sht2 As Worksheet
　　Dim MotoData As Variant
　　Dim ItemX As Variant
　　Dim myValue As Variant
　　Dim i As Long

　　Set Sht1 = ActiveSheet 'リストのあるシートを指定
　　Set Sht2 = Worksheets.Add 'ピボットテーブル用のシート

　　With Sht1

　　　　With .Range("A1").CurrentRegion
　　　　　　MotoData = .Resize(.Rows.Count - 1, 1).Offset(1, 1).Value
　　　　End With
　　　　ReDim myValue(LBound(MotoData, 1) To UBound(MotoData, 1), 1 To 1)
　　　　i = 0
　　　　For Each ItemX In MotoData
　　　　　　i = i + 1
　　　　　　myValue(i, 1) = ItemX & "-"
　　　　Next ItemX

　　　　With .PivotTableWizard(SourceType:=xlDatabase, _
　　　　　　　　SourceData:=.Range("A:B").SpecialCells(xlCellTypeConstants, _
　　　　　　　　　　23).Address(External:=True), _
　　　　　　　　TableDestination:=Sht2.Name & "!R1C1", ColumnGrand:=False)

　　　　　　.Format xlPTNone
　　　　　　.PivotFields("入力No.").Subtotals(1) = False
　　　　　　.AddFields RowFields:=Array("入力No.", "種別")
　　　　　　With .PivotFields("種別")
　　　　　　　　.Orientation = xlDataField
　　　　　　　　.Function = xlCount
　　　　　　　　.Calculation = xlRunningTotal
　　　　　　　　.BaseField = "入力No."
　　　　　　End With

　　　　　　i = 0
　　　　　　For Each ItemX In .DataBodyRange.Value
　　　　　　　　i = i + 1
　　　　　　　　myValue(i, 1) = myValue(i, 1) & Format(ItemX, "000")
　　　　　　Next ItemX

　　　　End With

　　　　With .Range("A1").CurrentRegion
　　　　　　With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
　　　　　　　　.ClearContents
　　　　　　　　.NumberFormat = "@"
　　　　　　　　.Value = myValue
　　　　　　End With
　　　　End With

　　End With

　　Set Sht1 = Nothing
　　Application.DisplayAlerts = False
　　Sht2.Delete
　　Application.DisplayAlerts = True
　　Set Sht2 = Nothing

End Sub

お礼

ありがとうございます。
ピボットテーブルという方法もあるんですね。
参考にさせていただきます。