ExcelVBAでのCountIf処理について質問

質問

お世話になります。
首記の件で困っております。
特に不具合なく動いているのですが、
あまりにも動作が遅い。。。
VBAは普段がりがりやっているのではないのですが、
今回の処理は約30万レコード分の処理があるのでどうしても
VBAでないときついと思いチャレンジしています。

やりたいことは、A列にある値がR列の限られたエリアにいくつ存在するか、
というチェック作業です。

コードを記載しますので、
どなたかやさしい突っ込みお願いしますｗ

Sub CntIf()
　　For myRow = 2 To 300000
　　　　　　Cells(myRow, 19) = WorksheetFunction.CountIf(Range("Q2:Q300000"), Cells(myRow, 1))
　　　　　　cntRec = cntRec + 1
　　　　　　Application.StatusBar = "処理実行中．．．．(現在 " & cntRec & "件)"
　　Next
End Sub
OS：WinXP
Office：2007Pro

回答No.3

noname#262398

Sub sample()
Dim a, q, qq, i&, j&

a = Range("a2:a300001").Value
q = Range("q2:q300001").Value
With CreateObject("scripting.dictionary")
For Each qq In q
.Item(qq) = .Item(qq) + 1
Next
For i = 0 To 200000 Step 100000
For j = 1 To 100000
If .exists(a(i + j, 1)) Then a(j, 1) = .Item(a(i + j, 1)) Else a(j, 1) = 0
Next
Cells(i + 2, 19).Resize(100000).Value = a '10万件ずつ分けて書き出し
Next
.removeall
End With
Erase a, q
End Sub

回答No.2

Wendy02

こんばんは。

検索範囲は、30万セル良いとしても、検索値も30万件にもなるのでしょうか。もう一度、その部分を検証したほうがよいと思います。検索値は、もっと少ないのではありませんか？

'標準モジュール

Sub Test1()
　　Dim rng As Range
　　Dim ar1() As Variant
　　Dim ar2() As Variant
　　Dim i As Long
　　Const mROW As Long = 300000 'カウント

　　ReDim ar2(1 To mROW)
　　Set rng = Range("Q2").Resize(mROW)
　　ar1 = Range("A2").Resize(mROW).Value　'検索値
　　ar1 = Application.Transpose(ar1)
　　For i = LBound(ar1) To UBound(ar1)
　　　　ar2(i) = WorksheetFunction.CountIf(rng, ar1(i))
　　Next
　　Application.DisplayAlerts = False
　　Range("S2").Resize(mROW).Value = Application.Transpose(ar2)
　　Application.DisplayAlerts = True
End Sub

回答No.1

nattocurry

検証していないので、効果があるかどうか判りませんが、私ならこうしますかねぇ。

(1)Application.ScreenUpdating を使って、処理中は画面描画をしないようにする。
(2)Valueプロパティを指定することで、VBAが自動判断する時間を減らす。(意味が無い行為かもしれません)
(3)ステータスバーに表示する数字用のカウンターを、myRowで代用する。
(4)盛り込んではいませんが、たとえば1000回ごとにしかステータスバーにカウンタを表示させないようにするとか。

Sub CntIf()
　　Application.ScreenUpdating = False
　　For myRow = 2 To 300000
　　　　　　Cells(myRow, 19).Value = WorksheetFunction.CountIf(Range("Q2:Q300000"), Cells(myRow, 1).Value)
　　　　　　Application.StatusBar = "処理実行中．．．．(現在 " & myRow - 1 & "件)"
　　Next
　　Application.ScreenUpdating = True
End Sub