[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『検索キーを３つ持たせて該当行をコピーしてくる』（じょり）
「検索キーを３つ持たせて該当行をコピーしてくる」マクロを組んでます
例：以下キー３つ
ABC
DEF
GHI
これらに部分一致する行をすべて抽出するマクロを組もうとしてます
ABCXXXX →抽出
XXX →抽出しない
DEFXXX →抽出
一度組んでみたのですが、動作が重たすぎて機能しません。
rangeで定義した関数（キー３つ分定義）
Set関数でfindnextした値を保持してすべて見つけるまでループ
見つけたらその都度別のシートにコピー
という内容です。
アドバイスいただけると幸いです。
＜ 使用 Excel：Excel2016mac、使用 OS：Windows10 ＞
（もこな２ ） 2020/01/04(土) 15:19
以下になります。
初心者なので、これは今後使わないほうがいい等もありましがら、
ご教授頂けると幸いです。
よろしくお願いいたします。
Dim myRange1 As range '検索にヒットしたセルを記録 Dim myRange2 As range Dim myRange3 As range Dim myRange4 As range Dim myRange5 As range Dim myRange6 As range Dim myRange7 As range Dim myRange8 As range
Dim firstCell As range '最初に検索にヒットしたセルを記録
Set myRange1 = Sheets("保存先").Cells.Find(what:="AAA", LookAt:=xlPart)
Set myRange2 = Sheets("保存先").Cells.Find(what:="BBB", LookAt:=xlPart)
Set myRange3 = Sheets("保存先").Cells.Find(what:="CCC")
Set myRange4 = Sheets("保存先").Cells.Find(what:="DDD", LookAt:=xlPart)
Set myRange5 = Sheets("保存先").Cells.Find(what:="FFF", LookAt:=xlPart)
Set myRange6 = Sheets("保存先").Cells.Find(what:="DDD", LookAt:=xlPart)
Set myRange7 = Sheets("保存先").Cells.Find(what:="FFF", LookAt:=xlPart)
Set myRange8 = Sheets("保存先").Cells.Find(what:="GGG", LookAt:=xlPart)
If Not myRange1 Is Nothing Then '検索対象が1件以上ある場合に下記コードを実行’
Set firstCell = myRange1
firstCell.Copy Sheets("抽出先").range(firstCell.Address)
Do
Set myRange1 = Sheets("保存先").Cells.findnext(myRange1) '（）内のセルの次のセルから検索を続行’
myRange1.Copy Sheets("抽出先").range(myRange1.Address)
Set myRange2 = Sheets("保存先").Cells.findnext(myRange2) '（）内のセルの次のセルから検索を続行’
myRange2.Copy Sheets("抽出先).range(myRange2.Address)
Set myRange3 = Sheets("保存先").Cells.findnext(myRange3) '（）内のセルの次のセルから検索を続行’
myRange3.Copy Sheets("抽出先").range(myRange3.Address)
Set myRange4 = Sheets("保存先").Cells.findnext(myRange4) '（）内のセルの次のセルから検索を続行’
myRange4.Copy Sheets("抽出先").range(myRange4.Address)
Set myRange5 = Sheets("保存先").Cells.findnext(myRange5) '（）内のセルの次のセルから検索を続行’
myRange5.Copy Sheets("抽出先").range(myRange5.Address)
Set myRange6 = Sheets("保存先").Cells.findnext(myRange6) '（）内のセルの次のセルから検索を続行’
myRange6.Copy Sheets("抽出先").range(myRange6.Address)
Set myRange7 = Sheets("保存先").Cells.findnext(myRange7) '（）内のセルの次のセルから検索を続行’
myRange7.Copy Sheets("抽出先").range(myRange7.Address)
Set myRange8 = Sheets("保存先").Cells.findnext(myRange8) '（）内のセルの次のセルから検索を続行’
myRange8.Copy Sheets("抽出先").range(myRange8.Address)
Loop While myRange1.Address <> firstCell.Address '最初のセルに戻るまでDo~Loopを継続’
End If
（じょり） 2020/01/04(土) 15:26
行？
シートのレイアウトを説明お願いします。
（マナ） 2020/01/04(土) 16:43
保存先：文章が３００行ほど入ってます
抽出先：ここに検索でひっかかった行をコピーしてきます
（今回はセルの位置は継承してますが、拘っている訳ではないです）
イメージつきますでしょうか？
（じょり） 2020/01/04(土) 16:51
保存先 シートでは
A列に３００行
J列に３００行
という風になってます。
検索がひっとした”セル”を持ってくる想定です。
（じょり） 2020/01/04(土) 16:53
（マナ） 2020/01/04(土) 17:00
＞保存先 シートでは A列に３００行 J列に３００行
ならば、その列のみ検索すれば、シート全体を見なくても良いですよね？
（もこな２ ） 2020/01/04(土) 17:56
↑が理解できてから、今度は複数のキーワードを対象にする（what:=××× ← ここを入れ替える）ことを考えたほうがよいです。
とりあえず、「or」パターンの研究用コードを提供しますので、ステップ実行して何をやっているのか調べてみてください。
Sub 名無しのマクロ()
Dim 検索値 As Variant
Dim 検索結果 As Range
Dim bufRNG As Range, MyRNG As Range
Dim 検索範囲 As Range
Set 検索範囲 = Sheets("保存先").Range("A1:A300,J1:J300")
Stop ' ←ブレークポイントの代わり
'▼「検索値」を変えながらループ処理
For Each 検索値 In Array("AAA", "BBB", "CCC", "DDD", "EEE", "FFF", "GGG")
Set bufRNG = 検索部(検索範囲, 検索値)
'▼「bufRNG」がNothingじゃないときだけ処理
If Not bufRNG Is Nothing Then
If 検索結果 Is Nothing Then
Set 検索結果 = bufRNG
Else
Set 検索結果 = Union(検索結果, bufRNG)
End If
End If
Next 検索値
If Not 検索結果 Is Nothing Then
'▼「検索結果」から一つずつ取り出して、コピペ（ループ処理）
For Each MyRNG In 検索結果
MyRNG.Copy Sheets("抽出先").Range(MyRNG.Address)
Next MyRNG
End If
End Sub
'--------------------------------------------------------------------
Function 検索部(検索範囲 As Range, 検索値 As Variant) As Range
Dim 発見セル As Range, 最初のセル番地 As String, tmpRNG As Range
'▼とりあえずFindメソッドで検索してみる
Set 発見セル = 検索範囲.Find(What:=検索値, LookIn:=xlValues, LookAt:=xlPart)
'▼Findメソッドで発見された場合のみFindNextメソッドで処理する
If Not 発見セル Is Nothing Then
最初のセル番地 = 発見セル.Address
Set tmpRNG = 発見セル
'▼ループ処理
Do
Set tmpRNG = 検索範囲.FindNext(tmpRNG)
'▼FindNextで見つかったセル番地が最初に見つかったセルと...
If tmpRNG.Address = 最初のセル番地 Then
'▼一致したら新たに覚えずループを抜ける
Exit Do
Else
'▼一致しなかったら「発見セル」に追加して覚えて次のセルを探す
Set 発見セル = Union(発見セル, tmpRNG)
End If
Loop
End If
'▼見つかった場合は「全部のセル」、見つからなかった場合は「Nothing」が格納される
Set 検索部 = 発見セル
End Function
（もこな２ ） 2020/01/04(土) 19:34
さて、コピーは
・行ごと丸々コピーするのか
・しかも同じ行位置にコピーする必要があるのか
確認したい。
既に対応策が提示されていますが、
フィルタでの別解が可能か考えています。
その前提を確認したい。
（γ） 2020/01/05(日) 11:16
よく見ていませんけど Findを使うよりは 検索条件と、検索範囲を配列で取得して 検索条件をループしてLike演算子で 検索範囲の各行を判断して、合致していたら 貼り付ける という ベタな方法のほうがいいような気がします。
検索条件の増減にも対応できますし・・・
（渡辺ひかる） 2020/01/05(日) 15:08
(γsさん）
・行ごと丸々コピーするのか ・しかも同じ行位置にコピーする必要があるのか 確認したい。
・セル単位で問題ありません（行コピーの必要はありません）
・同じ位置にコピーする必要はありません（ころがっていたコードを流用した関係でそうなってます）
既に対応策が提示されていますが、 フィルタでの別解が可能か考えています。 その前提を確認したい。 フィルタでの別解があればそちらで対応でも問題ありません。
（渡辺ひかるさん）
確かに、そうなのですが、まだまだVBAの扱いに慣れておらず、
find以外に方法があることを知りませんでした・・
配列にも少し抵抗があったもので・・
（じょり） 2020/01/06(月) 16:12
んと、、、値がA列とJ列に入っていて、
どちらも検索対象なのですか？
それから、結合セルは使ってますか？
（まっつわん） 2020/01/06(月) 16:27
私の発言の重点は、無限ループになっていることの説明にあったのですが、
それはスルーされてしまった。とほほ。
再チャレンジ。-----
ちょっと戻りますが、現在のコードは無限ループになっています。 重いどころじゃなく、永遠に止まらないはずです。
findとfindnextは3つの組みをそれぞれに持つわけではありません。 findnextというのは、あくまで直近に実行した検索条件をもとに繰り返します。 CCCを検索したあとでfindnextすると、CCCだけを記憶していて、 AAA、BBBのことはすっかり忘れて、最後に行ったCCCだけを繰り返し検索します。
すると、どうなるか。 最初にマッチしたセル位置(AAAのマッチ箇所）と一致することは無い （つまり、AAAとCCCが同じに含まれていない限り一致しない）ので、 Do ループの脱出条件を満たすことはなく、無限ループとなります。
質問への回答を拝見すると、
フィルタオプションを用いることで（それをコード化すれば）、
ほんの数行で，所望することは可能ですね。
A列とJ列それぞれで抽出して、他のシートに転記すればよいでしょう。
コードは示しませんが、やる気があれば、フィルタオプションにトライしてみてください。
（γ） 2020/01/06(月) 20:41
ヒントになるか。 FindNextでなく、Afterを使う。
・・・Find(値, After:=myRange1, ・・・・ （Jaka） 2020/01/07(火) 03:00
■１
例えば、
・検索の対象は、A列とJ列の【セルの値】
・キーワードを部分一致で「or（いずれかを含む）」検索
・出力先は、抽出先シートのA1以下にずら〜っと並べる
・セル結合はなし
という条件なら、既に提供した研究用のコードが理解できていれば、A列とJ列を別々に操作するだけなので割とすぐにできます。
（コピー対象の"セル"が連続していなくても、同じ列に存在する場合に限り一度にコピペすることが可能）
Sub 名無しのマクロ()
Dim 検索値 As Variant
Dim 検索結果 As Range
Dim bufRNG As Range, MyRNG As Range
Dim 列 As Variant
Dim 検索範囲 As Range
Dim dstRNG As Range: Set dstRNG = Worksheets("抽出先").Range("A1")
Stop ' ←ブレークポイントの代わり
For Each 列 In Array("A", "J")
Set 検索範囲 = Sheets("保存先").Columns(列)
For Each 検索値 In Split("AAA,BBB,CCC,DDD,EEE,FFF,GGG", ",")
Set bufRNG = 検索部(検索範囲, 検索値)
If Not bufRNG Is Nothing Then
If 検索結果 Is Nothing Then
Set 検索結果 = bufRNG
Else
Set 検索結果 = Union(検索結果, bufRNG)
End If
End If
Next 検索値
If Not 検索結果 Is Nothing Then
検索結果.Copy dstRNG
Set dstRNG = Worksheets("抽出先").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Set 検索結果 = Nothing
Next 列
End Sub
'--------------------------------------------------------------------
Function 検索部(検索範囲 As Range, 検索値 As Variant) As Range
Dim 発見セル As Range, 最初のセル番地 As String, tmpRNG As Range
Set 発見セル = 検索範囲.Find(What:=検索値, LookIn:=xlValues, LookAt:=xlPart)
If Not 発見セル Is Nothing Then
最初のセル番地 = 発見セル.Address
Set tmpRNG = 発見セル
Do
Set tmpRNG = 検索範囲.FindNext(tmpRNG)
If tmpRNG.Address = 最初のセル番地 Then
Exit Do
Else
Set 発見セル = Union(発見セル, tmpRNG)
End If
Loop
End If
Set 検索部 = 発見セル
End Function
■２
＞（ころがっていたコードを流用した関係でそうなってます）
余計なお世話でしょうが、流用するのはいいんですが、ちゃんとステップ実行をするなりして理解しないとご自身でメンテナンスできなくなっちゃうとおもいますし、適当に組んだ結果、データを破壊するようなものになっちゃった場合、取り返しが付かない結果を招くことがあることは留意しておいた方がよいです。
（マクロ実行後「元に戻す」で、実行前の状況に戻すことはできません）
■３
説明しておいてなんですが、１セルずつチェック（検索）しなくても、オートフィルタやフィルタオプションが使えるならそちらのアプローチも検討したほうがよいかもしれません。
"抽出"するならフィルタ系のアプローチの方が本筋な気がします。
（もこな２ ） 2020/01/07(火) 04:13
■４
＞find以外に方法があることを知りませんでした・・
＞配列にも少し抵抗があったもので・・
比較する部分は配列を使わず列挙する方法もあります。
Sub 実験2()
Dim dstRNG As Range: Set dstRNG = Worksheets("抽出先").Range("A1")
Dim MyRNG As Range
Dim i As Long
Dim フラグ As Boolean
Dim 列 As Variant
Stop '←ブレークポイントの代わり
With Worksheets("保存先")
For Each 列 In Array("A", "J")
For i = 1 To .Cells(Rows.Count, 列).End(xlUp).Row
Select Case True
Case .Cells(i, 列).Value Like "*AAA*": フラグ = True
Case .Cells(i, 列).Value Like "*BBB*": フラグ = True
Case .Cells(i, 列).Value Like "*CCC*": フラグ = True
Case .Cells(i, 列).Value Like "*DDD*": フラグ = True
Case .Cells(i, 列).Value Like "*EEE*": フラグ = True
Case .Cells(i, 列).Value Like "*FFF*": フラグ = True
Case .Cells(i, 列).Value Like "*GGG*": フラグ = True
Case Else: フラグ = False
End Select
If フラグ Then
If MyRNG Is Nothing Then
Set MyRNG = .Cells(i, 列)
Else
Set MyRNG = Union(MyRNG, .Cells(i, 列))
End If
End If
Next i
If Not MyRNG Is Nothing Then
MyRNG.Copy dstRNG
Set dstRNG = dstRNG.Offset(MyRNG.Count)
Set MyRNG = Nothing
End If
Next 列
End With
End Sub
'−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
Sub 実験3()
Dim dstRNG As Range: Set dstRNG = Worksheets("抽出先").Range("A1")
Dim フラグ As Boolean
Dim 検索範囲 As Range
Dim MyRNG As Range, tmpRNG As Range
Dim i As Long
Stop '←ブレークポイントの代わり
'▼検索部-----------------------------------------
With Worksheets("保存先")
Set 検索範囲 = Intersect(.UsedRange, .Range("A:A,J:J"))
End With
If 検索範囲 Is Nothing Then
MsgBox "データなし"
Exit Sub
End If
For Each tmpRNG In 検索範囲
Select Case True
Case tmpRNG.Value Like "*AAA*": フラグ = True
Case tmpRNG.Value Like "*BBB*": フラグ = True
Case tmpRNG.Value Like "*CCC*": フラグ = True
Case tmpRNG.Value Like "*DDD*": フラグ = True
Case tmpRNG.Value Like "*EEE*": フラグ = True
Case tmpRNG.Value Like "*FFF*": フラグ = True
Case tmpRNG.Value Like "*GGG*": フラグ = True
Case Else: フラグ = False
End Select
If フラグ Then
If MyRNG Is Nothing Then
Set MyRNG = tmpRNG
Else
Set MyRNG = Union(MyRNG, tmpRNG)
End If
End If
Next tmpRNG
'▲検索部-----------------------------------------
'▼複写部-----------------------------------------
If Not MyRNG Is Nothing Then
For Each tmpRNG In MyRNG
tmpRNG.Copy dstRNG.Offset(i)
i = i + 1
Next tmpRNG
End If
'▲複写部-----------------------------------------
End Sub
（もこな２） 2020/01/07(火) 18:30
無限ループしてたらから終わらなかったんですね・・
気づきませんでした・・
皆様のコードをステップ実行したり、
vbaの関数？を色々検索して学ばせていただきました。
For Each 〇 In Array とか・・
afterとか・・
使い方知りませんでした・・！
本当にありがとうございました！
皆様のように美しいコードが書けるよう精進したいですｗ
（じょり） 2020/01/12(日) 17:00
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.