リストにある文字列を含むか判定_改良版
2021年06月14日
前回作ったツールで１２万行のリストと照合をかけたら
４００行を処理するのに４６０秒。１行で１秒かかった。。。
それと、リストに空白セルがあると
誤カウントで処理が終わらないことが判明。
比較条件にリストが空白でないことを追加した。
IF Key1List(j) <> "" And
IF Key2List(j) <> "" And
処理時間については、
比較対象の列を配列に格納して、配列同士を比較する処理に変更してみた。
Dim KeyText(): ReDim KeyText(LastRow)
Cells(Gyo, KeyCol) = KeyText(Gyo)
セルの値を読み込む回数は変わらないので
これだけじゃダメかなと思いつつも実験。
結果はなんと、３０秒で処理完了。
そんな爆速になるなんてびっくり！
以下ソース。
４００行を処理するのに４６０秒。１行で１秒かかった。。。
それと、リストに空白セルがあると
誤カウントで処理が終わらないことが判明。
比較条件にリストが空白でないことを追加した。
IF Key1List(j) <> "" And
IF Key2List(j) <> "" And
処理時間については、
比較対象の列を配列に格納して、配列同士を比較する処理に変更してみた。
Dim KeyText(): ReDim KeyText(LastRow)
Cells(Gyo, KeyCol) = KeyText(Gyo)
セルの値を読み込む回数は変わらないので
これだけじゃダメかなと思いつつも実験。
結果はなんと、３０秒で処理完了。
そんな爆速になるなんてびっくり！
以下ソース。
Option Explicit
Sub リストの文字があるかどうか探す()
'https://kirinote.com/excelvba-listcharacter/
Const KeySHname = "keyData"
Const TableSHname = "tableData"
Const TitleRow = 1
Const KeyCol = 3 '検索対象列
Const ColOut = 4 '出力列
Dim LastRow As Long
Dim Key1List() As String
Dim Key2List() As String
Dim Gyo As Long, i As Long, j As Long
'GCTデータを配列に格納
With Worksheets(KeySHname)
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim Key1List(LastRow - 2) '配列の要素数を指定
ReDim Key2List(LastRow - 2) '配列の要素数を指定
'リストの文字列を配列に格納
For Gyo = 2 To LastRow
i = Gyo - 2
Key1List(i) = .Cells(Gyo, 1)
Key2List(i) = .Cells(Gyo, 2)
Next Gyo
End With
'格納前に初期化
Worksheets(TableSHname).Select
Range(Cells(TitleRow, ColOut), Cells(Rows.Count, ColOut + 1)).ClearContents
Cells(TitleRow, ColOut) = "Hit1"
Cells(TitleRow, ColOut + 1) = "Hit2"
LastRow = Cells(Rows.Count, KeyCol).End(xlUp).Row '最終行を更新
Dim KeyText(): ReDim KeyText(LastRow)
For Gyo = TitleRow + 1 To LastRow
Cells(Gyo, KeyCol) = KeyText(Gyo)
Next Gyo
For Gyo = TitleRow + 1 To LastRow
Application.StatusBar = "データ処理中（" & Gyo - 1 & "/" & LastRow - 1 & "）"
For j = 1 To UBound(Key1List)
'リストの文字列が含まれている場合、セルの背景色を塗る
If Key1List(j) <> "" And InStr(KeyText(Gyo), Key1List(j)) > 0 Then Cells(Gyo, ColOut) = Cells(Gyo, ColOut) + 1
If Key2List(j) <> "" And InStr(KeyText(Gyo), Key2List(j)) > 0 Then Cells(Gyo, ColOut + 1) = Cells(Gyo, ColOut + 1) + 1
Next j
Next Gyo
Application.StatusBar = ""
End Sub
PR
Comment