[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『自動連番の高速化』(タナ)
処理自体はできていますが、データが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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.