[[20190315173430]]　『自動連番の高速化』（タナ）　ページの最後に飛ぶ

『自動連番の高速化』（タナ）

処理自体はできていますが、データが5万件以上になりそうなので
すこしでも高速化出来ればと思い書き込ませていただきます。

元データ
[A] ~略~ [E] [F]
A 12:30 A12:30
A 12:30 A12:30
A 23:30 A23:30
A 23:30 A23:30
B 10:00 B10:00
B 10:00 B10:00

A列に名前、E列に時間が記入されており、事前にF列にA&Eでまとめられています。

実行後
[A] ~略~ [E] [F] [G] [H]
A 12:30 A12:30 1 A1
A 12:30 A12:30 1 A1
A 23:30 A23:30 2 A2
A 23:30 A23:30 2 A2
B 10:00 B10:00 1 B1
B 10:00 B10:00 1 B1

人毎に連番を振っていきます。下記がそのコードになります。

Sub 連番調査()

Dim LastRow As Long
Dim i As Long
Dim myRange As Range
Dim codeRange As Range

    LastRow = Range("E" & Rows.Count).End(xlUp).Row

        For i = 2 To LastRow
            Set myRange = Range(Cells(2, 6), Cells(i, 6))
            Set codeRange = Range(Cells(2, 7), Cells(i, 7))

            'E列が空白だったら中止
            If Cells(i, 6) = Empty Then
                    Exit Sub
            '人毎に番号振りなおし
            ElseIf Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(i, 1)), Cells(i, 1)) = 1 Then
                    Cells(i, 7) = 1
            'さらに時間ごとに区別
            ElseIf Application.WorksheetFunction.CountIf(myRange, Cells(i, 6)) = 1 Then
                    Cells(i, 7) = Cells(i, 7).Offset(-1) + 1
            '同じ時間には同じ番号
            Else
                    Cells(i, 7) = WorksheetFunction.Index(codeRange, _
                    WorksheetFunction.Match(Cells(i, 6), myRange, 0), 1)
            End If

            Cells(i, 8) = Cells(i, 1) & Cells(i, 7)

        Next i

Set myRange = Nothing
Set codeRange = Nothing

End Sub

まだ追加していませんが最終的にはH列に出来上がった「A1」をA列に代入予定です。
現在約30000件のデータで検証していますが、現段階で遅いため高速化を考えております。

不明な点や列ズレなどの矛盾がありましたらコードが正になります。
色々見ていただければ幸いです。よろしくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

 連番の振り方が...
 A列の人名?毎のF列の値をユニーク値として、ということで

 Sub test()
     Dim a, i As Long
     With Range("a2", Range("f" & Rows.Count).End(xlUp))
         a = .Value
         With CreateObject("Scripting.Dictionary")
             .CompareMode = 1
             For i = 1 To UBound(a, 1)
                 If Not .exists(a(i, 1)) Then
                     Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                 End If
                 If Not .Item(a(i, 1)).exists(a(i, 6)) Then
                     .Item(a(i, 1))(a(i, 6)) = Empty
                     .Item(a(i, 1))(a(i, 6)) = .Item(a(i, 1)).Count
                 End If
                 a(i, 1) = a(i, 1) & .Item(a(i, 1))(a(i, 6))
             Next
         End With
         .Columns("g").Value = a
     End With
 End Sub
（seiya） 2019/03/15(金) 18:36

 A列とE列で、同じ名前や時刻の間に違う名前や時刻が挟まらないなら、
 (同じ名前の同じ時刻は必ず連続しているなら)
 以下のコードが高速です。
 このコードはF列も必要ありません。

 Sub 連番調査2()

    With Range("E2", Range("E" & Rows.Count).End(xlUp)).Offset(, 2)
        .Formula = "=IF(A1<>A2,A2&1,IF(E1=E2,G1,A2&SUBSTITUTE(G1,A2,"""")+1))"
        .Value = .Value
    End With

 End Sub

（sy） 2019/03/15(金) 22:07

返信おそくなりました。
ためさせていただきましたところ、どちらも問題なく動きました。ありがとうございます！

seiyaさん
検索などからとりあえず目的の動きをするように組み立てたのですが、今見るとひどく不恰好だと感じます・・・
コレクションなどもっと勉強させていただきます。

syさん
元データはwebアンケートの抽出結果でして、同じ人が第2回第3回と回答した場合は一括で抽出され問題ありませんので、こちらを使わせていただきます。

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

（タナ） 2019/03/18(月) 14:55

コメント返信：

[ 一覧(最新更新順) ]

[[20190315173430]] 『自動連番の高速化』（タナ） ページの最後に飛ぶ

[[20190315173430]]　『自動連番の高速化』（タナ）　ページの最後に飛ぶ