「一致するものをすべて取り出したい」〜 エクセルを使うときによくある状況。
5000 x 5000 のセルの中の数値から、任意の1つの数と一致するものをすべて抽出するときのマクロを3パターン考えてみた。果たしてどのマクロの処理速度が一番早いか。
処理する内容
処理内容は至ってシンプル。
5000行 x 5000列＝25,000,000セルに入力されたランダムな数値（今回は1〜3000の数とした）がある。パッと思いついた任意の1つの数字（今回は2999）をこの中から探し出して、そのすべての行番号と列番号を取り出す。
この処理をおこなうマクロを３パターン用意した。皆さんなら処理内容を聞いてますどれを思いつくだろうか。
- セルを巡回して比較しながら抽出
一番左上のセルからFor~Nextのループを使って巡回し、Ifで一致・不一致を判断。 - すべてのセル値を二次配列に読み込んでから比較抽出
5000 x 5000セルを二次配列として読み込んで、配列内をFor~Nextのループを使って巡回し、Ifで一致・不一致を判断。 - 検索機能を使ってヒットしたものを抽出
Find、FindNextでヒットする値がなくなるまでDo~Loopを使って繰り返す。
そして果たして、どのパターンが一番早く処理できるのか。検証スタートです。
なお今回の3パターンのマクロ（プロシージャ）は1つのモジュールに記述し、モジュールの先頭に定数として検索値を設定している。
マクロ1 セルを巡回して比較しながら抽出
Sub Sample1()
' セルの値を順に比較して抽出
Dim tm1 As Date
tm1 = Format(Now(), "hh:mm:ss")
Debug.Print "Sample 1 -----------------"
Debug.Print "Start: " & tm1
Sheets("Sheet2").Cells.ClearContents
Dim quantity As Long
quantity = WorksheetFunction.CountIf(Range("B2:GJI5001"), fNum)
Dim extractValues() As Variant
ReDim extractValues(1 To quantity, 1 To 2)
Dim r As Long, c As Long, i As Long
i = 1
For c = 2 To 5001
For r = 2 To 5001
If Cells(r, c) = fNum Then
extractValues(i, 1) = Cells(r, 1)
extractValues(i, 2) = Cells(1, c)
i = i + 1
End If
Next r
Next c
Sheets("Sheet2").Range("A1:B" & quantity) = extractValues
Dim tm2 As Date
tm2 = Format(Now(), "hh:mm:ss")
Debug.Print "End: " & tm2
Debug.Print i & " values match"
Debug.Print DateDiff("s", tm1, tm2) & " seconds needed."
End Sub
マクロ2 すべてのセル値を二次配列に読み込んでから比較抽出
Sub Sample2()
' 二次配列に読み込んだセル値を比較して抽出
Dim tm1 As Date
tm1 = Format(Now(), "hh:mm:ss")
Debug.Print "Sample 2 -----------------"
Debug.Print "Start: " & tm1
Sheets("Sheet3").Cells.ClearContents
Dim targetRange As Range
Set targetRange = Range("B2:GJI5001")
Dim targetValues As Variant
targetValues = targetRange.Value
Dim quantity As Long
quantity = WorksheetFunction.CountIf(targetRange, fNum)
Dim extractValues() As Variant
ReDim extractValues(1 To quantity, 1 To 2)
Dim r As Long, c As Long, i As Long
i = 1
For c = 1 To 5000
For r = 1 To 5000
If targetValues(r, c) = fNum Then
extractValues(i, 1) = Cells(r + 1, 1)
extractValues(i, 2) = Cells(1, c + 1)
i = i + 1
End If
Next r
Next c
Sheets("Sheet3").Range("A1:B" & quantity) = extractValues
Dim tm2 As Date
tm2 = Format(Now(), "hh:mm:ss")
Debug.Print "End: " & tm2
Debug.Print i & " values match"
Debug.Print DateDiff("s", tm1, tm2) & " seconds needed."
End Sub
マクロ3 検索機能を使ってヒットしたものを抽出
Sub Sample3()
' エクセルの検索機能を使って抽出
Dim tm1 As Date
tm1 = Format(Now(), "hh:mm:ss")
Debug.Print "Sample 3 -----------------"
Debug.Print "Start: " & tm1
Sheets("Sheet4").Cells.ClearContents
Dim targetRange As Range
Set targetRange = Range("B2:GJI5001")
Dim quantity As Long
quantity = WorksheetFunction.CountIf(targetRange, fNum)
Dim extractValues() As Variant
ReDim extractValues(1 To quantity, 1 To 2)
Dim matchRange As Range
Dim orgAdd As String
Dim i As Long
Set matchRange = targetRange.Find(What:=fNum, LookIn:=xlValues)
If Not matchRange Is Nothing Then
orgAdd = matchRange.Address
i = 1
Do
extractValues(i, 1) = Cells(matchRange.Row, 1)
extractValues(i, 2) = Cells(1, matchRange.Column)
Set matchRange = targetRange.FindNext(After:=matchRange)
i = i + 1
Loop Until matchRange.Address = orgAdd
Else
Debug.Print "none."
End If
Sheets("Sheet4").Range("A1:B" & quantity) = extractValues
Dim tm2 As Date
tm2 = Format(Now(), "hh:mm:ss")
Debug.Print "End: " & tm2
Debug.Print i & " values match"
Debug.Print DateDiff("s", tm1, tm2) & " seconds needed."
End Sub
検証の結果
結果は次の通り。あっさりとまとめてどうぞ。
一旦すべてのセルを配列として読み込むマクロ2が一番早い、という結果は大方予想通りだったと思う。
しかし、意外にも検索機能は健闘するものだと思ったのは僕だけだろうか。
割とパッと一番最初に思いつきそうなマクロ1が圧倒的ダントツに遅かったのでした。
皆さんの予想は当たりましたか？
コメント