回答編集履歴

2

コード修正

2017/05/01 23:11

投稿

hatena19
hatena19

スコア33620

test CHANGED
@@ -122,7 +122,7 @@
122
122
 
123
123
  Dim i As Long
124
124
 
125
- Dim ary1
125
+ Dim ary1()
126
126
 
127
127
  Dim ary2(2 To 180000, 0) As Long
128
128
 
@@ -140,7 +140,7 @@
140
140
 
141
141
  With Sheets("条件")
142
142
 
143
- ary1 = .Range("A2:B6000")
143
+ ary1 = .Range("A2:B6000").Value
144
144
 
145
145
  For i = 6000 To 2 Step -1
146
146
 
@@ -160,7 +160,7 @@
160
160
 
161
161
  Next
162
162
 
163
- .Range("B2:B180000") = ary2
163
+ .Range("B2:B180000").Value = ary2
164
164
 
165
165
  End With
166
166
 

1

追記

2017/05/01 23:11

投稿

hatena19
hatena19

スコア33620

test CHANGED
@@ -38,7 +38,7 @@
38
38
 
39
39
 
40
40
 
41
-
41
+ 蛇足
42
42
 
43
43
  ---
44
44
 
@@ -85,3 +85,99 @@
85
85
  Debug.Print Format(Timer - T,"0.00秒")
86
86
 
87
87
  ```
88
+
89
+
90
+
91
+ 蛇足の蛇足
92
+
93
+ ---
94
+
95
+ サンプルを作成して当方の環境で処理速度を計測してみました。
96
+
97
+ "条件"シートに6000件のデータ、
98
+
99
+ 重複を排除してDictionaryに登録すると 3000件
100
+
101
+ "抽出結果"シートには180000件のデータ
102
+
103
+ 質問のコードで3秒ぐらい。
104
+
105
+ 同じデータなら、誤差範囲の差しかでませんでした。
106
+
107
+
108
+
109
+ でコードのチューンナップしてみました。
110
+
111
+ セル範囲からの読み込み、書き込みを配列を介して一括処理に変更してみました。
112
+
113
+ これで、処理時間が1/3に短縮できました。
114
+
115
+
116
+
117
+ ```
118
+
119
+ Public Sub dic_04()
120
+
121
+ Dim mydic As Object
122
+
123
+ Dim i As Long
124
+
125
+ Dim ary1
126
+
127
+ Dim ary2(2 To 180000, 0) As Long
128
+
129
+
130
+
131
+ Application.ScreenUpdating = False
132
+
133
+ Application.EnableEvents = False
134
+
135
+
136
+
137
+ Set mydic = CreateObject("Scripting.Dictionary")
138
+
139
+
140
+
141
+ With Sheets("条件")
142
+
143
+ ary1 = .Range("A2:B6000")
144
+
145
+ For i = 6000 To 2 Step -1
146
+
147
+ mydic(ary1(i - 1, 1)) = ary1(i - 1, 2)
148
+
149
+ Next i
150
+
151
+ End With
152
+
153
+
154
+
155
+ With Sheets("抽出結果")
156
+
157
+ For i = 2 To 180000
158
+
159
+ ary2(i, 0) = mydic.Item(.Cells(i, 1).Value)
160
+
161
+ Next
162
+
163
+ .Range("B2:B180000") = ary2
164
+
165
+ End With
166
+
167
+
168
+
169
+ Set mydic = Nothing
170
+
171
+
172
+
173
+ Application.EnableEvents = True
174
+
175
+ Application.ScreenUpdating = True
176
+
177
+ End Sub
178
+
179
+ ```
180
+
181
+
182
+
183
+