質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.59%

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

受付中

回答 4

投稿

  • 評価
  • クリップ 1
  • VIEW 29K+

score 18

求めている仕様に合ったコードを探すことは出来ましたが、重すぎて処理が終わりません。
(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)
                 '結果シートへ張り付ける行を変更するためプラス1
                 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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • mattuwan

    2019/03/01 19:58

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

    キャンセル

  • mattuwan

    2019/03/01 20:54

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

    キャンセル

回答 4

0

それほど無駄な処理があるとは思えませんでしたが、唯一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のスペルが間違っています。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

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

で、こんな流れで。

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

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

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

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

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分以上かかりそうでしょうか?

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.59%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る