データ量の多い重複値に連番付与するやり方について（処理時間がかなり要しており苦戦しています）

Question

どなたか有識者の方ご教示頂けないでしょうか。

現在、重複レコードに連番（通し番号）を付与といった処理を行うために作成しています。

コード自体は問題はなく動作できているのですが、
データが20万を超えて尚且つ重複リストが1万以上超過していると
中々処理時間に要し、おおよそ10分ぐらい時間掛かっている状況です。

▼処理の流れ
①リストを配列へ格納
②①で格納した配列から重複リストを連想配列へ格納
③重複リストの分だけループ処理
④重複リストと一致判別し、レコードと連番を結合分を配列へ格納
⑤配列データをセル上へ反映

▼処理前後のイメージ
処理前　　 処理後
A　　　|　 A1
B　　　|　 B1
A　　　|　 A2
D　　　|　 D1
A　　　|　 A3
※上記ではアルファベットで表記していますが、
実際はコード+日付+ステータスの結合した文字列となります。

▼処理に時間掛かっている要因
恐らく重複リストの要素が1万以上あることが一番の要因で
③～⑤の処理に負担が掛かっているのではと推測しています。

このような処理を行う際は重複となる要素や条件を付け加えて重複リストの数を減らすことが
必然となってくるのでしょうか....。

現在のコードを記載しますので、
どなたか他に処を早める最善のやり方や他の処理方法などあればご教示頂けると幸いです。

Sub 連番付与()

Dim dcdname As Variant, dccount As Variant
Dim i, j
Dim Cnt As Long
Dim mRow As Long
Dim dname As String
Dim myKey As Variant
Dim list As Variant

    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(3)
    
'▼画面更新を無効化
Application.ScreenUpdating = False
    
With ws1

    '連想配列
    Set dcdname = CreateObject("Scripting.Dictionary")
    Set dccount = CreateObject("Scripting.Dictionary")

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

    'O列を配列格納
    list = .Range("O1:O" & mRow)
    
    'ループ
    For i = 2 To mRow

        '値を変数へ
        dname = list(i, 1)
        
        '重複しないリストを連想配列へ格納
        If Not dcdname.Exists(dname) Then
            dcdname.Add dname, dname
        Else
            '重複しているリストを連想配列へ格納
            If Not dccount.Exists(dname) Then
                 dccount.Add dname, dname
            End If
        End If
    Next i

    myKey = dccount.Keys
    Cnt = 1

    '重複しているリスト分ループして連番
    For i = 0 To UBound(dccount.Items)

        For j = 1 To UBound(list)
        
            If list(j, 1) = myKey(i) Then
            
                'レコードと連番の結合分を配列へ格納
                list(j, 1) = list(j, 1) & Cnt
                 Cnt = Cnt + 1

            End If
        Next j

        Cnt = 1

    Next i
           
    '配列をO列に反映
    .Range("O1:O" & mRow) = list
    
    '配列解放
    Set dcname = Nothing
    Set dccount = Nothing
    
End With
    
'▼画面更新を有効化
Application.ScreenUpdating = True

End Sub

Answer 1

Dictionaryの Item に連番を格納するようにすれば、Dictionaryは一つですみますし、ループも1回ですみます。ループが1回で済む分、速度アップすると思います。

Sub 連番付与Sample()

    Dim dcdname As Object
    Dim i
    Dim mRow As Long
    Dim dname As String
    Dim list As Variant

    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(1)

    '▼画面更新を無効化
    Application.ScreenUpdating = False

    With ws1

        '連想配列
        Set dcdname = CreateObject("Scripting.Dictionary")

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

        'A列を配列格納
        list = .Range("O1:O" & mRow).Value

        'ループ
        For i = 1 To mRow

            '値を変数へ
            dname = list(i, 1)

            If Not dcdname.Exists(dname) Then
                '初めてのリストは連番1
                dcdname.Add dname, 1
                list(i, 1) = dname & 1
            Else
                 '既出のリストは 連番 + 1
                 dcdname(dname) = dcdname(dname) + 1
                 list(i, 1) = dname & dcdname(dname)
            End If
        Next i


        '配列をO列に反映
        .Range("O1:O" & mRow) = list

        '配列解放
        Set dcdname = Nothing

    End With

    '▼画面更新を有効化
    Application.ScreenUpdating = True

End Sub

Comments

[quark87139]

ご回答ありがとうございます。
また分かりやすいように僕のコードから修正頂きありがとうございます。

ポイントとしては
処理時間の遅延要因
・ループは1回で済ませるようにする
↓
・ループを1回で済ませるために連番をItemへ格納
※Itemへ格納することでDictionaryも１つで回せる

ということですよね。
他の方のコードでもそうなんですが、
おっしゃるように極力ループは1回で済ませるように逆算して組み立てる力も大事ということを改めて痛感しました。

ありがとうございました。

Answer 2

セルにアクセスするのではなく、配列化して操作するというのが、定番です。
後は書き込みなどで、関係する自動更新をOFFにしておくなど。

以下参考
シートへの高速なアクセス
第114回.セル範囲⇔配列（マクロVBA高速化必須テクニック）

Excel VBA 高速化アプローチ

Answer 3

これでどうでしょうか。

With ws1
    Set dcdname = CreateObject("Scripting.Dictionary")
    mRow = .Cells(Rows.Count, 1).End(xlUp).Row
    list = .Range("O1:O" & mRow)
    For i = 2 To mRow
        dname = list(i, 1)
        dcdname(dname) = dcdname(dname) + 1
        list(i, 1) = list(i, 1) & dcdname(dname)
    Next i
    .Range("O1:O" & mRow) = list
    Set dcdname = Nothing
End With

Comments

[quark87139]

早速のご回答ありがとうございます。

頂いたコードで処理時間も1秒もかからず僕が考えていたものと同様の結果となりました。
(コードもコンパクトで驚愕しています...)

改めて僕のコードと比較するとあまりにも無駄な処理が付け加えているのが分かる上に
処理速度が遅くても当然な結果ですね..。
Dictionaryは1個で回し、ループは1回で済ますというのがポイントといったところでしょうか。

これで終わりとせずに頂いたコードから自分なりに解釈して他のところで活用できないか模索していきます。ありがとうございました。