グループごとに連番をふる

いつもお世話になっております。
同じ商品ごとに連番を振りたいのです。
下記のコードは同じ商品ごとに
同じ番号をふっています。
これを連番にしたいのです。
添付したファイルのように
Ａ列　商品
Ｂ列　商品ごと同じ番号
Ｃ列　同じ商品ごとに連番
わかる方おしえてくれませんでしょうか
よろしくお願いいたします。
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

質問者からの補足コメント

• 

  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回にわけました。

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/10/14 17:44

• 

  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

    補足日時：2020/10/14 17:44

• 

  はい一度ソートかけてやります。
  2行　バナナ
  3行　みかん
  4行　バナナ
  5行　バナナ
  このような形です

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/10/14 17:46

No.3 ベストアンサー 回答者： tom04 回答日時： 2020/10/14 17:54

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

この回答へのお礼

はやいです
ありがとうございました。

お礼日時：2020/10/14 17:59

No.2 回答者： tatsumaru77 回答日時： 2020/10/14 17:44

同じグループは必ず１つのかたまりになっていますか。

（提示された図はそのように見えます）
それとも
2行　バナナ
3行　みかん
4行　バナナ
5行　バナナ
のように１つのかたまりになっていないケースもありますか。

No.1 回答者： tom04 回答日時： 2020/10/14 17:37

こんにちは！

関数ではダメですか？

画像の配置だと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