回答編集履歴
2
さらに追記
answer
CHANGED
|
@@ -82,7 +82,6 @@
|
|
|
82
82
|
Debug.Print "setColor "; t & "秒かかりました。"
|
|
83
83
|
|
|
84
84
|
End Sub
|
|
85
|
-
|
|
86
85
|
```
|
|
87
86
|
|
|
88
87
|
ドメインリスト 20,000件、テキストのNGドメイン 3,000件のサンプルデータを rnd関数で自動生成しました。
|
|
@@ -90,3 +89,78 @@
|
|
|
90
89
|
当方の環境(Win10 64bit, Excel2016 32bit, CPU Core i7, RAM 16GB)
|
|
91
90
|
|
|
92
91
|
質問の追記のコードに `Application.EnableEvents = False` `Application.ScreenUpdating = True` を追加したもので、53秒前後、上記のコードで、18秒前後でした。
|
|
92
|
+
|
|
93
|
+
追記の追記
|
|
94
|
+
---
|
|
95
|
+
さらにさらにチューンナップしてみました。
|
|
96
|
+
|
|
97
|
+
**チューンナップ方針**
|
|
98
|
+
- ２重のループ内で、Like演算子で部分一致チェックをしているが、これに時間がかかっているようだ。そこで、 `ADomain Like "*" & NgDomain & "*"` を `InStr(ADomain , NgDomain ) > 0` 変更してみたら、処理時間が半分に短縮できた。
|
|
99
|
+
- InStrって高速なんだな！ならば、検索対象ドメインを連結して一つの文字列として、InStrで検索したらどうだろう。
|
|
100
|
+
|
|
101
|
+
```
|
|
102
|
+
Sub SetColor4()
|
|
103
|
+
Dim OpenFileName As String
|
|
104
|
+
Dim Buf As String
|
|
105
|
+
Dim aryNgDomain
|
|
106
|
+
Dim aryADomain()
|
|
107
|
+
Dim strADomain As String
|
|
108
|
+
Dim aryRDomain()
|
|
109
|
+
Dim NgDomain, ADomain
|
|
110
|
+
Dim n As Long, p As Long, p0 As Long
|
|
111
|
+
|
|
112
|
+
Sheet1.Cells.Interior.Color = xlNone '背景色リセット
|
|
113
|
+
OpenFileName = Application.GetOpenFilename("テキスト文書,*.txt")
|
|
114
|
+
|
|
115
|
+
Dim t As Single
|
|
116
|
+
t = Timer
|
|
117
|
+
|
|
118
|
+
Application.EnableEvents = False
|
|
119
|
+
Application.ScreenUpdating = False
|
|
120
|
+
Application.Calculation = xlCalculationManual
|
|
121
|
+
|
|
122
|
+
'テキストを一気に配列に読み込む
|
|
123
|
+
With CreateObject("Scripting.FileSystemObject")
|
|
124
|
+
With .GetFile(OpenFileName).OpenAsTextStream
|
|
125
|
+
Buf = .ReadAll
|
|
126
|
+
.Close
|
|
127
|
+
End With
|
|
128
|
+
End With
|
|
129
|
+
aryNgDomain = Split(Buf, vbCrLf)
|
|
130
|
+
|
|
131
|
+
With Workbooks(1).Worksheets(1)
|
|
132
|
+
aryADomain = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
|
|
133
|
+
End With
|
|
134
|
+
'Transposeで１次元配列に変換して、Joinで結合
|
|
135
|
+
strADomain = "|" & Join(WorksheetFunction.Transpose(aryADomain), "|") & "|"
|
|
136
|
+
|
|
137
|
+
'NGドメインに一致するドメインを配列に格納
|
|
138
|
+
For Each NgDomain In aryNgDomain
|
|
139
|
+
p = 1
|
|
140
|
+
Do
|
|
141
|
+
p = InStr(p, strADomain, NgDomain, vbBinaryCompare)
|
|
142
|
+
If p = 0 Then Exit Do
|
|
143
|
+
p0 = InStrRev(strADomain, "|", p, vbBinaryCompare) + 1
|
|
144
|
+
ReDim Preserve aryRDomain(n)
|
|
145
|
+
p = InStr(p, strADomain, "|")
|
|
146
|
+
aryRDomain(n) = Mid(strADomain, p0, p - p0)
|
|
147
|
+
n = n + 1
|
|
148
|
+
Loop
|
|
149
|
+
Next
|
|
150
|
+
|
|
151
|
+
'該当ドメインの背景色設定
|
|
152
|
+
With Workbooks(1).Worksheets(1).Range("A1")
|
|
153
|
+
.AutoFilter Field:=1, Criteria1:=aryRDomain, Operator:=xlFilterValues
|
|
154
|
+
.CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
|
|
155
|
+
.AutoFilter
|
|
156
|
+
End With
|
|
157
|
+
Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone
|
|
158
|
+
Application.EnableEvents = True
|
|
159
|
+
Application.ScreenUpdating = True
|
|
160
|
+
Application.Calculation = xlCalculationAutomatic
|
|
161
|
+
|
|
162
|
+
t = Timer - t
|
|
163
|
+
Debug.Print "setColor2 "; t & "秒かかりました。"
|
|
164
|
+
End Sub
|
|
165
|
+
```
|
|
166
|
+
結果、１秒！！で終わりました。
|
1
追記
answer
CHANGED
|
@@ -13,4 +13,80 @@
|
|
|
13
13
|
Application.EnableEvents = True
|
|
14
14
|
```
|
|
15
15
|
|
|
16
|
-
を挿入すると速度はかなり改善されると思います。
|
|
16
|
+
を挿入すると速度はかなり改善されると思います。
|
|
17
|
+
|
|
18
|
+
追記
|
|
19
|
+
---
|
|
20
|
+
さらなる高速化してみました。
|
|
21
|
+
|
|
22
|
+
**チューンナップ方針**
|
|
23
|
+
|
|
24
|
+
- テキストファイルはFileSystemObjectで全文を読み込む（Line Input で１行ずつ読み込むより高速）、Splitで行毎の配列にする
|
|
25
|
+
- セルに一つずつアクセスせずに、検索対象セルを一気に配列に代入して、配列にアクセスする。
|
|
26
|
+
- 上記２つの配列をFor Eachでループさせて、条件チェックして、該当するドメインを動的配列に格納。
|
|
27
|
+
- AutoFilter の Criteria1 に上記の動的配列を設定して、実行する（１回の処理で済む）
|
|
28
|
+
|
|
29
|
+
```
|
|
30
|
+
Sub SetColor()
|
|
31
|
+
Dim OpenFileName As String
|
|
32
|
+
Dim buf As String
|
|
33
|
+
Dim aryNgDomain
|
|
34
|
+
Dim aryADomain()
|
|
35
|
+
Dim aryRDomain()
|
|
36
|
+
Dim NgDomain, ADomain
|
|
37
|
+
Dim n As Long
|
|
38
|
+
|
|
39
|
+
Sheet1.Cells.Interior.Color = xlNone '背景色リセット
|
|
40
|
+
OpenFileName = Application.GetOpenFilename("テキスト文書,*.txt")
|
|
41
|
+
|
|
42
|
+
Dim t As Single
|
|
43
|
+
t = Timer
|
|
44
|
+
|
|
45
|
+
Application.EnableEvents = False
|
|
46
|
+
Application.ScreenUpdating = False
|
|
47
|
+
|
|
48
|
+
'テキストを一気に配列に読み込む
|
|
49
|
+
With CreateObject("Scripting.FileSystemObject")
|
|
50
|
+
With .GetFile(OpenFileName).OpenAsTextStream
|
|
51
|
+
buf = .ReadAll
|
|
52
|
+
.Close
|
|
53
|
+
End With
|
|
54
|
+
End With
|
|
55
|
+
aryNgDomain = Split(buf, vbCrLf)
|
|
56
|
+
|
|
57
|
+
'NGドメインに一致するドメインを配列に格納
|
|
58
|
+
With Workbooks(1).Worksheets(1)
|
|
59
|
+
aryADomain = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
|
|
60
|
+
For Each NgDomain In aryNgDomain
|
|
61
|
+
For Each ADomain In aryADomain
|
|
62
|
+
If ADomain Like "*" & NgDomain & "*" Then
|
|
63
|
+
ReDim Preserve aryRDomain(n)
|
|
64
|
+
aryRDomain(n) = ADomain
|
|
65
|
+
n = n + 1
|
|
66
|
+
End If
|
|
67
|
+
Next
|
|
68
|
+
Next
|
|
69
|
+
End With
|
|
70
|
+
|
|
71
|
+
'該当ドメインの背景色設定
|
|
72
|
+
With Workbooks(1).Worksheets(1).Range("A1")
|
|
73
|
+
.AutoFilter Field:=1, Criteria1:=aryRDomain, Operator:=xlFilterValues
|
|
74
|
+
.CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
|
|
75
|
+
.AutoFilter
|
|
76
|
+
End With
|
|
77
|
+
Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone
|
|
78
|
+
Application.EnableEvents = True
|
|
79
|
+
Application.ScreenUpdating = True
|
|
80
|
+
|
|
81
|
+
t = Timer - t
|
|
82
|
+
Debug.Print "setColor "; t & "秒かかりました。"
|
|
83
|
+
|
|
84
|
+
End Sub
|
|
85
|
+
|
|
86
|
+
```
|
|
87
|
+
|
|
88
|
+
ドメインリスト 20,000件、テキストのNGドメイン 3,000件のサンプルデータを rnd関数で自動生成しました。
|
|
89
|
+
それを元に実験してみました。
|
|
90
|
+
当方の環境(Win10 64bit, Excel2016 32bit, CPU Core i7, RAM 16GB)
|
|
91
|
+
|
|
92
|
+
質問の追記のコードに `Application.EnableEvents = False` `Application.ScreenUpdating = True` を追加したもので、53秒前後、上記のコードで、18秒前後でした。
|