あるセルの文字列と一致するセルに色付け

実現したいこと

データ量の増加に伴い、現在使用しているものでは動作が重く高速化したい。

前提

A列の文字列とC列の文字列が一致した場合、そのセル(C列)に色付けをしたいです。(完全一致)
もともと多くて100行前後のデータ量だったので問題なかったのですが、
20万行を超えるデータを扱うことになり大変困っております。。

発生している問題・エラーメッセージ

データ量が多く、処理に20時間以上かかってしまう。

該当のソースコード

Sub Sample1()

Dim i As Long, k As Long, myStr As String
Dim myFound As Range, myFirst As Range

For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
myStr = Cells(i, "A")
Set myFound = Range("C:C").Find(what:=myStr, LookIn:=xlValues, lookat:=xlWhole)

If Not myFound Is Nothing Then
Set myFirst = myFound
GoTo 処理
Do
Set myFound = Range("C:C").FindNext(after:=myFound)

If myFound.Address = myFirst.Address Then Exit Do
GoTo 処理

処理:
For k = 1 To Len(myFound)

If Mid(myFound, k, Len(myStr)) = myStr Then
myFound.Characters(Start:=k, Length:=Len(myStr)).Font.ColorIndex = 3
End If

Next k
Loop
End If
Next i

End Sub

試したこと

配列を使えばよいのかとは思うのですが、当方配列に関する知識が浅く。。。

補足情報（FW/ツールのバージョンなど）

ご参考までに、A列は1万行、C列は20万行ほどあります。

行動規範の内容に同意します

回答3件

このようなケースの時、dictionaryを使用すると、劇的に処理速度がアップできます。
以下のようにしてください。

VBA
1Public Sub 同一文字列の色付け()
2    Dim maxrow1 As Long
3    Dim maxrow2 As Long
4    Dim dicT As Object
5    Dim key As String
6    Dim wrow As Long
7    maxrow1 = Cells(Rows.Count, "A").End(xlUp).Row
8    maxrow2 = Cells(Rows.Count, "C").End(xlUp).Row
9    Set dicT = CreateObject("Scripting.Dictionary")
10    For wrow = 2 To maxrow1
11        key = Cells(wrow, "A").Value
12        dicT(key) = wrow
13    Next
14    For wrow = 2 To maxrow2
15        key = Cells(wrow, "C").Value
16        If dicT.exists(key) = True Then
17            Cells(wrow, "C").Font.ColorIndex = 3
18        Else
19            Cells(wrow, "C").Font.ColorIndex = xlAutomatic
20        End If
21    Next
22End Sub
23

投稿2023/04/16 09:23

tatsu99

総合スコア5447

試しに20万行で試してみましたが、高スぺＰＣでもいつ終わるか分からない速度でしたね…。
Find関数はかなり時間がかかるみたいなので使わない方が吉です。

だからと言ってforでそのままでも多少かかるので、配列でforを回して分別していく方法がいいかと思います。

※コードは独学なのでもっとわかりやすい書き方あるかもです。

VBA
1Sub ColorExe2()
2    Dim LLst As Variant
3    Dim RLst As Variant
4    Dim L_LR As Long
5    Dim R_LR As Long
6    Dim Arr As Variant
7    Dim i As Long
8    Dim ColorList As Variant
9    
10    Application.ScreenUpdating = False
11    
12    L_LR = Cells(Rows.Count, 1).End(xlUp).Row
13    LLst = Range(Cells(1, 1), Cells(L_LR, 1))
14    
15    R_LR = Cells(Rows.Count, 3).End(xlUp).Row
16    RLst = Range(Cells(1, 3), Cells(R_LR, 3))
17    
18    ReDim ColorList(1 To UBound(RLst))
19    
20    For i = 1 To UBound(ColorList)
21        ColorList(i) = 0
22    Next i
23    
24    For Each Arr In LLst
25        For i = LBound(RLst) To UBound(RLst)
26            If Arr = RLst(i, 1) Then
27                ColorList(i) = 3
28            End If
29        Next i
30    Next Arr
31    
32    For i = 1 To R_LR
33        Cells(i, 3).Font.ColorIndex = ColorList(i)
34    Next i
35    
36    Application.ScreenUpdating = True
37End Sub