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

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

新規登録して質問してみよう
ただいま回答率
85.49%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

4回答

45266閲覧

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

lq_hm_165912

総合スコア18

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

1クリップ

投稿2019/02/28 08:22

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

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

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

VBA

1 2Sub search() 3 4 '対象とするシートの宣言 5 6 '検索値があるシート 7 Dim targetSheet As Worksheet 8 '対象データがあるシート 9 Dim seathSheet As Worksheet 10 '検索結果を出力するシート 11 Dim outputSheet As Worksheet 12 13 Set targetSheet = Worksheets("検索値") 14 Set seathSheet = Worksheets("データ") 15 Set outputSheet = Worksheets("検索結果") 16 17 '比較値の最終行取得 18 Dim row As Long 19 row = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).row 20 '出力行数 21 Dim cnt As Long: cnt = 2 22 23 For i = 2 To row 24 '検索結果のセル 25 Dim foundCell As Range 26 '検索値のセル 27 Dim searthCell As Range 28 29 Set searthCell = targetSheet.Cells(i, 1) 30 '検索値が空白ならスキップ 31 If Not searthCell = "" Then 32 '検索結果取得 33 Set foundCell = seathSheet.Cells.Find(searthCell, LookAt:=xlWhole, SearchOrDer:=xlByColumns) 34 35 '検索結果が得られなかった場合スキップ 36 If Not foundCell Is Nothing Then 37 Set FirstCell = foundCell 38 39 Do 40 '比較値に一致した一覧の行をコピー 41 seathSheet.Rows(foundCell.row).Copy 42 '結果シートに張り付け 43 outputSheet.Rows(cnt).PasteSpecial (xlPasteValues) 44 '結果シートへ張り付ける行を変更するためプラス1 45 cnt = cnt + 1 46 '次を検索 47 Set foundCell = seathSheet.Cells.FindNext(foundCell) 48 49 '次の検索が最初と同じor存在しなかった場合次の検索値へ 50 If foundCell.Address = FirstCell.Address Then 51 Exit Do 52 ElseIf foundCell Is Nothing Then 53 Exit Do 54 End If 55 Loop 56 57 End If 58 End If 59 Next 60 61End Sub 62

気になる質問をクリップする

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

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

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

mattuwan

2019/03/01 10:58

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

2019/03/01 11:54

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

回答4

0

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

VBA

1Sub search002() 2 Dim rngList As Range 3 Dim rngKeys As Range 4 Dim rngResult As Range 5 Dim rngTarget As Range 6 Dim c As Range 7 Dim sFAddress As String 8 Dim t As Single 9 10 t = Timer 11 12 '作業に必要なセル範囲の特定 13 Set rngList = Worksheets("データ").Range("A1").CurrentRegion.Columns("A") 14 With Worksheets("検索値") 15 Set rngKeys = Intersect(.Cells, .Offset(1), .Columns("A")) 16 End With 17 Set rngResult = Worksheets("検索結果").Range("A2") 18 19 For Each c In rngKeys 20 '既に結果に書き出したか存在確認 21 If WorksheetFunction.CountIf(rngResult.CurrentRegion.Columns("A"), c.Value) Then 22 '検索値が空白でないなら 23 If Not IsEmpty(c.Value) Then 24 25 Set rngTarget = rngList.Find(c.Value, LookAt:=xlWhole, SearchOrDer:=xlByColumns) 26 27 If Not rngTarget Is Nothing Then 28 sFAddress = rngTarget.Address 29 Do 30 rngTarget.EntireRow.Copy rngResult 31 Set rngResult = rngResult.Offset(1) 32 33 Set rngTarget = rngList.FindNext(rngTarget) 34 Loop Until sFAddress = rngTarget.Address 35 End If 36 End If 37 End If 38 Next 39 40 MsgBox Timer - t & "秒掛かりました。" 41End Sub

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

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

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

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

投稿2019/03/01 11:53

mattuwan

総合スコア2136

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

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

VBA

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

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

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

投稿2019/03/01 10:56

mattuwan

総合スコア2136

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

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

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

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

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

投稿2019/02/28 14:41

退会済みユーザー

退会済みユーザー

総合スコア0

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

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

VBA

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

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

VBA

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

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

投稿2019/02/28 09:07

ttyp03

総合スコア16998

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

まだベストアンサーが選ばれていません

会員登録して回答してみよう

アカウントをお持ちの方は

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

ただいまの回答率
85.49%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問