マクロ実行時のフリーズについて

質問

下記のような処理を実行すると応答なしとフリーズになってしまいます。
解決方法について教えてください

やりたいこと　：8列目にコードが並んでいて、重複コード（2回目以降）のものは赤色にする
困っていること：実行すると応答なしでフリーズしてしまう
→変数の上限が20000ではなく5000だと問題なく動く

Sub (1)()

Dim i As Long
For i = 3 To 20000
If Application.WorksheetFunction.CountIf(Range(Cells(3, 8), Cells(i, 8)), Cells(i, 8)) > 1 Then
Cells(i, 8).Font.ColorIndex = 3
End If
Next i

End Sub

回答No.5

mitarashi

ユニークリスト取得にどの手段が一番速いか試してみた事がありますが、CountIfは数十万件になるとリソース不足で止まってしまいました。当方の試した中で最も速かったのは、配列に取り込んでから、連想配列で重複チェックするものでした。
今回のケースに置き換えて試してみましたが、20万件のデータで、0.5秒弱かかりました。(Core i5 3.2GHz,xl2010-32bit)
（もっとも、ウン万件のデータに色をつけてスクロールして探すという行為はとても時間がかかるので、別の目印を考えた方が良いとは思います）
Declare Function GetTickCount Lib "kernel32" () As Long
Const maxRow As Long = 200000

'時間を測定するために余分なコードが入っています。#3さんのコードをご参照下さい。
Sub checkOverlap()
Dim targetRange As Range
Dim i As Long
Dim buf As Variant
Dim myDic As Object
Dim myKey As String
Dim StartTime As Long

StartTime = GetTickCount
Application.ScreenUpdating = False
Set targetRange = Sheets(1).Range("H3:H" & maxRow)
targetRange.Interior.Color = vbRed
buf = targetRange.Value
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(buf, 1)
myKey = CStr(buf(i, 1))
If Not myDic.exists(myKey) Then
targetRange.Cells(i, 1).Interior.ColorIndex = xlNone
myDic.Add myKey, ""
End If
Next i
Application.ScreenUpdating = True
Debug.Print GetTickCount - StartTime
End Sub

'物好きな方のために、所定個数のサンプルデータを作成するコード
Sub makeSampleData()
Dim targetRange As Range

Application.ScreenUpdating = False
Set targetRange = Sheets(1).Range("H3:H" & maxRow)
targetRange.Formula = "=int(10000*rand())+1"
targetRange.Value = targetRange.Value
Application.ScreenUpdating = True
End Sub

連想配列は言語によっては標準で持っている機能ですが、VBAの場合はDictionaryオブジェクトというのを使う必要があります。「VBA Dictionary」で検索してみて下さい。下記は一例です。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html

回答No.4

tom04

No.2です。
たびたびごめんなさい。
前回のコードでは重複がない場合、エラーとなりますので、
↓のコードに変更してください。
簡単に
＞On Error Resume Next
の1行を入れてもよいのですが、少し丁寧にやってみました。

Sub Sample2()
Dim i As Long, lastRow As Long, c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "H").End(xlUp).Row
Range(.Cells(3, "H"), .Cells(lastRow, "H")).AdvancedFilter Action:=xlFilterCopy, _
copytorange:=wS.Range("A1"), unique:=True
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range(.Cells(3, "H"), .Cells(lastRow, "H")), wS.Cells(i, "A")) > 1 Then
Set c = .Range("H:H").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
.Rows(2).AutoFilter field:=8, Criteria1:=wS.Cells(i, "A")
.Rows(c.Row).Hidden = True
Range(.Cells(3, "H"), .Cells(lastRow, "H")).SpecialCells(xlCellTypeVisible).Font.ColorIndex = 3
.AutoFilterMode = False
End If
Next i
.Range("A2").Select
wS.Range("A:A").Clear
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

検証せずに投稿してごめんなさいね。m（_ _）m

回答No.3

nda23

セルの内容を触ると時間がかかります。
従って、セルの集合内を検索すると相当な時間がかかります。
ということで、内部データにコードを記録して、ここから
検索するようにします。以下はサンプルです。

'マシン起動時からの経過ミリ秒数を求めるAPI
Declare Function GetTickCount Lib "kernel32" () As Long
Sub サンプル()
Dim 行　　 As Long
Dim コード As String
Dim 要素数 As Long
Dim 配列() As String
Dim 索引　　As Long

'参考用に開始時刻を記録する
Dim 開始　　As Long
開始 = GetTickCount
'4行目から開始する
For 行 = 4 To 20000
　　'セルの値を取得する
　　コード = Cells(行, 8)
　　'既存データ内を検索する
　　For 索引 = 1 To 要素数
　　　　'一致したらループを抜ける
　　　　If コード = 配列(索引) Then Exit For
　　Next
　　'検出できたか調べる
　　If 索引 > 要素数 Then
　　　　'検出できなかったので、配列を拡張して記録する
　　　　要素数 = 要素数 + 1
　　　　ReDim Preserve 配列(1 To 要素数)
　　　　配列(要素数) = コード
　　Else
　　　　'検出したので、文字を赤色にする
　　　　Cells(行, 8).Font.ColorIndex = 3
　　End If
Next
'参考用に経過時間を表示する
Debug.Print "経過時間は"; GetTickCount - 開始; "ミリ秒です"
End Sub

もし、コードが32ビットで表現可能な整数と分かっているなら、
コードや配列の変数型をLongにすれば、より高速になります。

回答No.2

tom04

こんにちは！
万単位の行をループさせるとどうしても「応答なし」の状態になってしまいますね。

そこで別案です。
元データはSheet1にあるとします。
Sheet2を作業用のSheetとして使用するようにしていますので、Sheet2は全く使っていない状態にしておいてください。

↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。
おそらく数万行あっても数秒で終わると思います。

尚、Sheet1のデータはA列からあり、2行目は項目行になっているとします。

Sub Sample1()
Dim i As Long, lastRow As Long, c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "H").End(xlUp).Row
Range(.Cells(3, "H"), .Cells(lastRow, "H")).AdvancedFilter Action:=xlFilterCopy, _
copytorange:=wS.Range("A1"), unique:=True
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row
Set c = .Range("H:H").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
.Rows(2).AutoFilter field:=8, Criteria1:=wS.Cells(i, "A")
.Rows(c.Row).Select
Selection.EntireRow.Hidden = True
Range(.Cells(3, "H"), .Cells(lastRow, "H")).SpecialCells(xlCellTypeVisible). _
Font.ColorIndex = 3
.AutoFilterMode = False
Next i
.Range("A2").Select
wS.Range("A:A").Clear
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

回答No.1

米沢 栄蔵（@YON56）

単に計算量が多くて、計算結果が表示だけではないでしょうか。

Range(Cells(3, 8), Cells(i, 8))のiが問題です。
CountIfする範囲を固定すれば計算結果は、すぐに表示されるはずです。
検索対象が3行目-20000行目という意味であれば、
i=20000
とします。
しかし、検索値は Cells(i, 8)のままです。