検索値があった場合は一致した行を転記する

Question

求めている仕様に合ったコードを探すことは出来ましたが、重すぎて処理が終わりません。
(5分放置して40行ほどしか出力されません)

おそらくFor文ではなくFindや配列を組めばいいと思うのですが、締め切りが近いので自分でも考えながらこちらでも質問させてください。

1シート目に検索値、2シート目にデータ、3シート目に検索結果を置いています。
検索値シートのA列がデータシートのA列と一致した場合に、一致したデータシートの行を検索結果シートに出力するイメージです。
検索値、データシートのA列は重複してます。
(ともに変動するため、AAAという値がどちらのシートにも複数ある可能性があります)
検索値だけでも重複を削除するマクロを噛ませた方が良いのかもしれません。
以下検索したコードです。

Sub search()
     
    '対象とするシートの宣言
     
    '検索値があるシート
    Dim targetSheet As Worksheet
    '対象データがあるシート
    Dim seathSheet As Worksheet
    '検索結果を出力するシート
    Dim outputSheet As Worksheet
     
    Set targetSheet = Worksheets("検索値")
    Set seathSheet = Worksheets("データ")
    Set outputSheet = Worksheets("検索結果")
     
    '比較値の最終行取得
    Dim row As Long
    row = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).row
    '出力行数
    Dim cnt As Long: cnt = 2
     
    For i = 2 To row
        '検索結果のセル
        Dim foundCell As Range
        '検索値のセル
        Dim searthCell As Range
         
        Set searthCell = targetSheet.Cells(i, 1)
        '検索値が空白ならスキップ
        If Not searthCell = "" Then
            '検索結果取得
            Set foundCell = seathSheet.Cells.Find(searthCell, LookAt:=xlWhole, SearchOrDer:=xlByColumns)
            
            '検索結果が得られなかった場合スキップ
            If Not foundCell Is Nothing Then
               Set FirstCell = foundCell
 
               Do
                 '比較値に一致した一覧の行をコピー
                 seathSheet.Rows(foundCell.row).Copy
                 '結果シートに張り付け
                 outputSheet.Rows(cnt).PasteSpecial (xlPasteValues)
                 '結果シートへ張り付ける行を変更するためプラス１
                 cnt = cnt + 1
                 '次を検索
                 Set foundCell = seathSheet.Cells.FindNext(foundCell)
                  
                 '次の検索が最初と同じor存在しなかった場合次の検索値へ
                 If foundCell.Address = FirstCell.Address Then
                     Exit Do
                 ElseIf foundCell Is Nothing Then
                     Exit Do
                 End If
            Loop
                 
            End If
        End If
    Next
     
End Sub

Comments

[mattuwan]

表の中に、1行丸ごと空白の行が存在するということは、ありえるのでしょうか？
あると無しでは、セル範囲を特定するのに考え方が変わります。

[mattuwan]

あ、あと、検索値は一度に最大何個ぐらいを想定してますか?

Answer 1

コードのインデントが崩れそうなので、新たに回答します。

Sub search002()
    Dim rngList As Range
    Dim rngKeys As Range
    Dim rngResult As Range
    Dim rngTarget As Range
    Dim c As Range
    Dim sFAddress As String
    Dim t As Single

    t = Timer

    '作業に必要なセル範囲の特定
    Set rngList = Worksheets("データ").Range("A1").CurrentRegion.Columns("A")
    With Worksheets("検索値")
        Set rngKeys = Intersect(.Cells, .Offset(1), .Columns("A"))
    End With
    Set rngResult = Worksheets("検索結果").Range("A2")

    For Each c In rngKeys
        '既に結果に書き出したか存在確認
        If WorksheetFunction.CountIf(rngResult.CurrentRegion.Columns("A"), c.Value) Then
            '検索値が空白でないなら
            If Not IsEmpty(c.Value) Then

                Set rngTarget = rngList.Find(c.Value, LookAt:=xlWhole, SearchOrDer:=xlByColumns)

                If Not rngTarget Is Nothing Then
                    sFAddress = rngTarget.Address
                    Do
                        rngTarget.EntireRow.Copy rngResult
                        Set rngResult = rngResult.Offset(1)

                        Set rngTarget = rngList.FindNext(rngTarget)
                    Loop Until sFAddress = rngTarget.Address
                End If
            End If
        End If
    Next

    MsgBox Timer - t & "秒掛かりました。"
End Sub

高速化のコツとしては、
1）実行される行数を減らす
2)文章中のピリオドの数を減らす(変数に代入してしまう）
3)無駄なループを避ける（なんなら、VBAでループの処理を書かないようにする）
4）いちいちセルの読み書きをすることを止める（2次配列変数に値を書き出してから作業する）
などでしょうか。

上記のコードではまだまだ、
WorksheetFunction.CountIf　や
rngList.Find　が、
ボトルネックになっていそうな気がします。
検索機能（Findメソッド）では1個しか答えが返って来ないので、
オートフィルターやフィルターオプションの機能を使うことで、
複数の答えが得られれば、ループの回数を減らせると思います。

空白セルのチェックが要るなら最初から空白セル以外のセルを対象にしたらいいかもですね。
あと、For～NextよりFor Each ~ Nextの方が速いという噂をきいたことがあります。
が、それは副次的な要素も絡むので単純に比較できないかも知れません。

このコードだとどれくらいの時間で作業が終わるでしょうか？
やっぱり5分以上かかりそうでしょうか？

Answer 2

改善の余地は多々ありそうですが、
とりあえず気になった点。

    For i = 2 To row
        '検索結果のセル
        Dim foundCell As Range
        '検索値のセル
        Dim searthCell As Range

ループの中で変数を宣言してはいけません。
中身を変えられるのが変数なので、
1回宣言すれば、あとは中身を変えるだけでいいです。

変数を宣言するということは、
メモリ上に保存する領域を確保するということなので、
無駄なことを多数やることになります。
とりあえず、それをやったらどれくらい改善されますかね？
ループ内でDimを使ったことがないので、
どのくらい改善されるか興味があります。
ちなみにRedimをループの外に出したら、かなり改善されましたが、
やってることが違うのでどうなんだろうとは思いますが。。。

Answer 3

時間が無いのでアイデアだけですが、コピー先(シート3)に転記されるデータが下記でよければ、オートフィルタを使ってさくっと行けないでしょうか。

• 転記されたデータの行順は問わない
• データシートに同じ検索値の行があれば全て転記

で、こんな流れで。
0. 検索値のユニークリストを作る
ディクショナリーのキーを使うのがよくある方法のような気がします。
0. 作成したユニークリストの項目毎にループ
0. データシートをループ要素(検索値)でオートフィルタ
0. 表示されている行のみコピー
範囲の指定はSpecialCells(xlCellTypeVisible)辺りを使えば楽でしょうか。

そもそもオートフィルタで早いのかの検証もしていませんけど…。

Answer 4

それほど無駄な処理があるとは思えませんでしたが、唯一Findだけがシート内全セルを対象にしているのが影響しているような気がします。
検索対象をA列限定するだけでも速くならないでしょうか。

Set foundCell = seathSheet.Columns(1).Find(searthCell, LookAt:=xlWhole, SearchOrDer:=xlByColumns)

更に言えば、A列のデータがある行に限定したほうがいいかもしません。

Dim row2 As Long
Dim searchRange As Range
row2 = seathSheet.Cells(seathSheet.Rows.Count, 1).End(xlUp).row
Set searchRange = seathSheet.Range("A1:A" & row2)
～
Set foundCell = searchRange.Find(searthCell, LookAt:=xlWhole, SearchOrDer:=xlByColumns)

余談ですがsearchのスペルが間違っています。