![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
いつもお世話になっております。
同じ商品ごとに連番を振りたいのです。
下記のコードは同じ商品ごとに
同じ番号をふっています。
これを連番にしたいのです。
添付したファイルのように
A列 商品
B列 商品ごと同じ番号
C列 同じ商品ごとに連番
わかる方おしえてくれませんでしょうか
よろしくお願いいたします。
Sub 同じデータに同じ連番をふる()
Dim DicName As Variant
Dim i As Long
Dim j As Long
Dim Cnt As Long
Dim LastRow As Long
Dim GetName As String
Dim myKey As Variant
Set DicName = CreateObject("Scripting.Dictionary")
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
GetName = Cells(i, 1)
If Not DicName.Exists(GetName) Then
DicName.Add GetName, GetName
End If
Next i
myKey = DicName.Keys
Cnt = 1
For i = 0 To UBound(DicName.Items)
For j = 1 To LastRow
If Cells(j, 1) = myKey(i) Then
Cells(j, 2) = Cnt
End If
Next j
Cnt = Cnt + 1
Next i
Set DicName = Nothing
End Sub
![「グループごとに連番をふる」の質問画像](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/d/543034290_5f86b5b48557a/M.gif)
No.3ベストアンサー
- 回答日時:
No.1です。
VBAの方法をご希望だというコトなので・・・
お示しのコードに近い形にしてみました。
Sub Sample2()
Dim myDic As Object
Dim i As Long
Dim lastRow As Long
Dim myStr As String
Dim myR
Set myDic = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'//▼範囲を配列に格納//
myR = Range(Cells(2, "A"), Cells(lastRow, "C"))
For i = 1 To UBound(myR, 1)
myStr = myR(i, 1) & "_" & myR(i, 2)
If Not myDic.exists(myStr) Then
myDic.Add myStr, 1
Else
myDic(myStr) = myDic(myStr) + 1
End If
myR(i, 3) = myDic(myStr)
Next i
'//▼セルに一気に吐き出す//
Range(Cells(2, "A"), Cells(lastRow, "C")) = myR
Set myDic = Nothing
End Sub
※ A列とB列は必ず「対」になっているという前提です。
仮にA列が「バナナ」であっても、B列が「2」であれば別物とみなされます。m(_ _)m
No.2
- 回答日時:
同じグループは必ず1つのかたまりになっていますか。
(提示された図はそのように見えます)
それとも
2行 バナナ
3行 みかん
4行 バナナ
5行 バナナ
のように1つのかたまりになっていないケースもありますか。
No.1
- 回答日時:
こんにちは!
関数ではダメですか?
画像の配置だとC2セルに
=COUNTIFS(A$2:A2,A2,B$2:B2,B2)
という数式を入れフィルハンドルでダブルクリック!
これでできると思います。
どうしてもVBAでやりたい!というコトであれば
関数をそのまま使うのが一番簡単だと思います。
Sub Sample1()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Range(Cells(2, "C"), Cells(lastRow, "C"))
.Formula = "=COUNTIFS(A$2:A2,A2,B$2:B2,B2)"
.Value = .Value
End With
End Sub
こんな感じで・・・
※ データ量が極端に多い(数万行)の場合は
お示しのようなVBAで配列で処理すればほとんど時間を要しないと思います。m(_ _)m
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) vba 重複データ合算 5 2023/07/05 18:55
- Visual Basic(VBA) このマクロの説明文を教えてほしいです。 1 2023/01/12 09:17
- Visual Basic(VBA) VBAコードが作動せず、どこに問題があるのか教えて下さい。 3 2023/06/13 13:20
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Excel(エクセル) VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。 4 2022/04/07 02:38
- Excel(エクセル) マクロ(データ取得と転記)について教えてください 3 2022/12/24 12:18
- Visual Basic(VBA) VBAで質問ですが、皆さんはどの様に導き出しているのでしょうか? 6 2022/05/03 21:53
- Visual Basic(VBA) VBA 請求書自動作成 3 2022/04/24 01:58
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたい 6 2023/01/23 12:00
- Visual Basic(VBA) 【VBA】特定のワードが入っている行全体を塗りつぶしたい 4 2022/04/20 15:22
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
IF文、条件分岐の整理方法
-
VBAコードのインデント表示
-
時間短縮のために、テキストフ...
-
Excel VBA 選択範囲の罫線色の...
-
マクロの記録を使用したマクロ...
-
VB.net(VB)で、フォームにExcel...
-
IEを使わないでhtmlテキストを...
-
Excelセルに入力された文字の色...
-
VBAなくなるの?
-
【ExcelVBA】値を変更しながら...
-
VBA 別ブックから条件に合うも...
-
VBAの質問です、複数のテキスト...
-
エクセルのマクロについて教え...
-
ワードVBA どの表か知ることは...
-
エクセルのマクロについて教え...
-
エクセルのVBAコードについて教...
-
エクセルのマクロについて教え...
-
エクセルのVBAコードについて教...
-
エクセルのマクロについて教え...
-
ExcelVBA修正のお願い
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBAなくなるの?
-
VBAでCOPYを繰り返すと、処理が...
-
vba 削除
-
プログラミング
-
Excelのマクロについて教えてく...
-
Excelのマクロについて教えてく...
-
エクセルのVBAコードについて教...
-
久しぶりのプログラミング
-
ユーザーフォームに別シートか...
-
エクセルVBAコードで教えて下さ...
-
VBA 別ブックからコピペしたい...
-
ExcelのVBAコードについて教え...
-
VBAコードについて教えてくださ...
-
vba アクティブシートの名前変...
-
Excelのマクロについて教えてく...
-
エクセルVBA
-
Geogebraの操作方法について
-
マクロの記録を使用したマクロ...
-
Excel(M365) Vlookup/セル反転(...
-
Excel 範囲指定スクショについ...
おすすめ情報
tom04様
検索しましたら下記のコードありました。
これを改良版でお願いできますでしょうか。
急いでないのでわたしも考えます
お願いできますでしょうか。
Set myDic = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
myR = Range(Cells(1, "G"), Cells(lastRow, "G"))
For i = UBound(myR, 1) To 1 Step -1
文字数の制限のため2回にわけました。
If Not myDic.exists(myR(i, 1)) Then
myDic.Add myR(i, 1), 1
myR(i, 1) = myR(i, 1) & "(1)"
Else
myDic(myR(i, 1)) = myDic(myR(i, 1)) + 1
myR(i, 1) = myR(i, 1) & "(" & myDic(myR(i, 1)) & ")"
End If
Range(Cells(1, "G"), Cells(lastRow, "G")) = myR
Set myDic = Nothing
はい一度ソートかけてやります。
2行 バナナ
3行 みかん
4行 バナナ
5行 バナナ
このような形です