エクセル マクロ 複数条件と部分一致

質問

１対多数の検索　と　複数条件（部分一致と全部一致）のためコードがよくわかりません。
例えば、xlpart、Match、Index、Offset　を使い下記の処理ができる方法はありますでしょうか。

下記A～C列のリストがあります。（10000行程度）
（Sheet1）
　　A　　　　　　　B　　　　　　C　　　
１　0075926　　VU　　　 SerialA　
２　0623450　　VU　　 　 SerialA　・
３　0002356　　WM　　　 SerialA　
４　0157592　　WM　 　　SerialB　・
５　0023456　　WM　 　　SerialB
（・・・以下１００００行程度続く）

(1)　Sheet2の検索値A１に部分一致するものを、Sheet１のA列から選ぶ。
(2)　複数の検索結果値がでてしまうので、さらにSheet2のB1と「全部一致」する
ものをSheet1のB列から選ぶ。
(3)　上記(1)、(2)の条件を満たすものをSheet１のA列から1つ選ぶ。さらにその行の
C列を転記する。（複数該当する場合は上位記載のものでかまいません。）

※数値はエクセルの書式設定で文字列にしてあります。
（検索前のSheet２）
　　A　 　　　　 B　　　　　　　　C
１　7592　　　　WM
２　2345　　　　VU
（以下１００００行程度続く）

（検索後のSheet２）
　　A　 　　　 B　　　　　　　　 C 　　　 D
１　7592　　　　WM　　　　0157592　　SerialB 　　　 　※7592は、Sheet1のA4に該当する。
２　2345　　　　VU　　　　0623450　 　SerialA　　　　　※2345は、Sheet1のA2に該当する。
（以下１００００行程度続く）

部分一致の後の全部一致の複合的なコードの組み方がわかりません。
繰り返し処理（ForやLoop）をよく理解していないからだと思います。どなたかご教示くださいますでしょうか。大変困っておりよろしくお願いいたします。(WindowsXp、Office2003)

回答No.3

keithin · ベストアンサー

＞例えば、xlpart、Match、Index、Offset　を使い…

そういったやり口ではない，簡単な方法で。
＃ただし簡単のため「複数ヒットの場合の採用基準」を変更しています

＃簡単のため，シート１，２ともに「１行目にタイトル行」「２行目から実データ」というレイアウトを仮定します。常識的な作表と判断しています。

サンプル：
Sub macro1()
　Dim h As Range
　Application.ScreenUpdating = False

’シート２のデータを巡回
　For Each h In Worksheets("Sheet2").Range("A2:A" & Worksheets("Sheet2").Range("A65536").End(xlUp).Row)

　’該当データの抽出
　　Worksheets("Sheet1").Range("A:B").AutoFilter field:=1, Criteria1:="*" & h & "*"
　　Worksheets("Sheet1").Range("A:B").AutoFilter field:=2, Criteria1:=h.Offset(0, 1)

　’転記
　　h.Offset(0, 2) = Worksheets("Sheet1").Range("A65536").End(xlUp)
　　h.Offset(0, 3) = Worksheets("Sheet1").Range("C65536").End(xlUp)
　Next
　Worksheets("Sheet1").AutoFilterMode = False
　Application.ScreenUpdating = True
End Sub

お礼

keithin様はどれくらいのご経験なのでしょうか。どうやったら、このように書けるか勉強方法を教えていただきたいくらいです。こちらは１ヶ月の経験です。すぐ動かすことができました。１行１行理解していきたいと思います。ありがとうございます。

回答No.4

merlionXX

順列組み合わせ方式、オートフィルタ方式と出ているようですので、検索方式の一例を書きます。

Sub test01()
　　Dim i As Long
　　Dim ws(1 To 2) As Worksheet
　　Dim fnd As Range
　　Dim fa As String '以上変数宣言
　　Set ws(1) = Sheets("Sheet1")
　　Set ws(2) = Sheets("Sheet2")
　　Application.ScreenUpdating = False '画面更新停止
　　For i = 1 To ws(2).Cells(Rows.Count, "A").End(xlUp).Row 'Sheet2検査値の数取得
　　　　Set fnd = ws(1).Columns("A:A").Find(What:=ws(2).Cells(i, 1).Value, LookAt:=xlPart) '部分一致検索
　　　　If Not fnd Is Nothing Then 'あれば
　　　　　　fa = fnd.Address 'アドレスを控える
　　　　　　Do '繰り返す
　　　　　　　　Set fnd = ws(1).Columns("A:A").FindNext(fnd)
　　　　　　　　If fnd.Offset(, 1).Value = ws(2).Cells(i, 2).Value Then '条件が一致すれば
　　　　　　　　　　With ws(2).Cells(i, 3) '転記
　　　　　　　　　　　　.Value = fnd.Text
　　　　　　　　　　　　.Offset(, 1) = fnd.Offset(, 2).Text
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　Loop While Not fnd Is Nothing And fa <> fnd.Address
　　　　End If
　　Next i
　　Application.ScreenUpdating = True '画面更新停止解除
End Sub

お礼

merlionXX様へ
前の方のおっしゃるFindを使ってご教示いただきありがとうございます。すぐ動きました。
相当なハイレベルなので、勉強の題材にし、１行１行理解しようと思います。どのようにしたらスラスラかけるようになるのでしょうか～。やはり頭の作りの違いでしょうか（笑）　ご教示ありがとうございます。

回答No.2

imogasi

検索というのはエクセルのSheet1のデータの全行を対象にしないとならないと思います。
便利なような関数なども、裏では全データを対象にしているはず。対象が既にメモリ上データ（関数など）とシート上のデータに違いはあるが。
ですから最終行までのA列全セル繰り返しで良いでしょう。
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("A65536").End(xlUp).Row
y = sh2.Range("A1")
z = sh2.Range("B1")
'--
For i = 2 To d
x = sh1.Cells(i, "A")
p1 = InStr(x, y) 'ｙが含まれるか
If p1 <> 0 Then
p2 = InStr(x, z) 'zが含まれるか
If p2 <> 0 Then
sh1.Cells(1, "C") = sh1.Cells(i, "A")
Exit For '１つ見つかったら打ち切り
End If
End If
Next i
End Sub
質問はしっかり書けていると思うが、全般の構想力が弱いため、質問文の表現が長くなりすぎとおもう。
もっと簡単なことでは。
もっと色々上達し、上記に飽き足らなくなったら、Findなどを使えないか考えたら良い。
Findは初心者には難しいと思っている。
B1に全部一致を求めるならB1と等しいと聞く（判別する）か、長さが一致するかを聞けばよいだろう。

お礼

すぐ教えていただきありがとうございます。試していますが、焦っているのかまだ動きません。もう少し解読してみたいと思います。自分のやり方が悪いのかもしれません。
＞p1 = InStr(x, y) 'ｙが含まれるか　のInStrについてわからないので後日調べてみます。
また、鋭いご指摘にも感謝いたします。imogasi様はどれくらいのご経験なのでしょう。ベストアンサーにしたいのですが、ベストアンサーが１つなので困りました。

回答No.1

tom04

こんにちは！
こんな感じですかね？

複数該当する場合は上位を表示ということですので・・・

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
For i = ws1.Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If ws1.Cells(i, 1) Like "*" & ws2.Cells(j, 1) & "*" And ws1.Cells(i, 2) = ws2.Cells(j, 2) Then
With ws2.Cells(j, 3)
.Value = ws1.Cells(i, 1)
.Offset(, 1) = ws1.Cells(i, 3)
End With
End If
Next i
Next j
End Sub

For～Next　を使っていますので時間がかかるかもしれません。

他によい方法があればごめんなさいね。m(__)m

お礼

すぐ教えていただきありがとうございます。試していますが、焦っているのかまだ動きません。もう少し解読してみたいと思います。自分のやり方が悪いのかもしれません。勉強して別の立場で、このように教えれるレベルになりたいと思います。tom04様はどれくらいのご経験なのでしょう。ベストアンサーにしたいのですが、ベストアンサーが１つなので困りました。