質問: FirstCell.Address Then Exit Do ElseIf foundCell Is Nothing Then Exit Do End If Loop End If End If Next End Sub ```
回答: コードのインデントが崩れそうなので、新たに回答します。 ``` 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分以上かかりそうでしょうか?