行抽出マクロについて教えてください。

質問

エクセルのシート１のＢ列に整理番号（順不同）が書かれてあり、シート２のＣ列にも整理番号（順不同）が書かれてあります。
シート１は約数千行・１００列、シート２は約数万行・１００列です。このシート１のＢ１と同じ整理番号をシート２のＣ列より上から検索して、最初に見つかったセル（仮にＣ７）を含む行をシート３にコピーする。
次にＢ２について同様にしてシート３にコピーする。この時の検索範囲はＣ８以下（Ｃ７以上は検索範囲外）とする。
同様な作業を続けて、最終的には、シート３のＣ列がシート１のＢ列と同じにしたい。
これをマクロで組みたい。どなたかご教授お願いいたします。

回答No.3

imogasi · ベストアンサー

例データ
Sheet1　の　B列B2:B８
1112
1122
1324
1432
1122
1421
1204
Sheet2の　C2:D21
1112 a
1122 b
1324 c
1333 d
1324 e
1981 f
1432 g
1111 h
1122 i
1632 j
1421 k
1204 l
3201 m
5123 n
1122 o
1122 u
1125 t
1421 r
1832 w
1204 x
コード（標準モジュール）
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
k = 2 'Sheet３第２行から順次書き出し
p = 2 'Sheet1第２行から開始
'---
d1 = sh1.Range("B65536").End(xlUp).Row 'Sheet1の最下行
d2 = sh2.Range("C65536").End(xlUp).Row 'Sheet2の最下行
For i = 2 To d1 'Sheet1の最下行まで各行について繰り返し
' MsgBox sh1.Cells(i, "B")
Set frw = sh2.Range(sh2.Cells(p, "C"), sh2.Cells(d2, "C")).Find(what:=sh1.Cells(i, "B")) '検索
If frw Is Nothing Then '見つからないとき
sh1.Cells(i, "D") = "Not Find"
'MsgBox sh1.Cells(i, "A") & "E"
Else '見つかったとき
r = frw.Row
' MsgBox r
sh2.Cells(r, "A").EntireRow.Copy 'その行コピー
sh3.Activate
sh3.Cells(k, "A").Select
ActiveSheet.Paste '行貼り付け
k = k + 1 '書き出し先を１行下へずらす
p = r '探索範囲上限をづらす
End If
Next i
End Sub
データの事実上の仕組みが
＞この時の検索範囲はＣ８以下（Ｃ７以上は検索範囲外）とする
との関連でよくわからない（意味のある場合が、すぐには想像できない）ので、十分テストしてみてください。

お礼

imogasiさん、いつもありがとうございます。おかげさまでできました。シート２の検索範囲については、シート１共、時系列データですので、前回の時点以降で最初の該当データを採用するプログラムが目的です。説明が不十分で失礼しました。プログラム内容については、十分に中身を見て、参考にさせていただきます。本当にありがとうございました

回答No.2

Wendy02

こんばんは。

私は、良く分らないですね。
例えば、シート2 のC列の行が、全部で、30,000 行だとしますね。

#エクセルのシート１のＢ列に整理番号（順不同）が書かれてあり、
#シート２のＣ列にも整理番号（順不同）が書かれてあります。

これについて、順不同として、重複がないものと考えます。

シート１のB1と同じ整理番号をシート2のC列より上から検索して、見つかったセルの行が、C30000 だとしますかね。そうしたら、

#この時の検索範囲はＣ８以下（Ｃ７以上は検索範囲外）とする。
としたら、C30000以降はありませんから、それで、お終いになってしまいます。仮にですが、極端な例で考えてみると、その説明のままではロジックがおかしいように思います。どこか、説明が足りないのではないでしょうか？

具体的な内容とかないので、そのままのご設問では、私には、このマクロは作ることは可能でも、実用性は低いのではないかなって思いました。

お礼

どうもありがとうございました。おかげさまでできました。シート２の検索範囲については、シート１共、時系列データですので、前回の時点以降で最初の該当データを採用するプログラムが目的です。説明が不十分で失礼しました。本当にありがとうございました。

回答No.1

papayuka

> この時の検索範囲はＣ８以下

必ず見つかったセルより下で次の物を探すって事？
こんな感じかなと思って書いてみました。
但し、見つかったセルより下に次の物が無い事を想定してません。

Sub Test()
Dim r As Range, fr
Set fr = Worksheets("Sheet2").Range("C65536")
With Worksheets("Sheet1")
　　 For Each r In .Range(.Range("B1"), .Range("B65536").End(xlUp))
　　　　 Set fr = Worksheets("Sheet2").Columns(3). _
　　　　　　　　　Find(r.Value, after:=fr, lookat:=xlWhole)
　　　　 If fr Is Nothing Then Exit For
　　　　 fr.EntireRow.Copy Destination:= _
　　　　　　　Worksheets("Sheet3").Range("C65536").End(xlUp).Offset(1, 0).EntireRow
　　 Next r
End With
End Sub

お礼

ありがとうございました。おかげさまでできました。シート２の検索範囲については、シート１共、時系列データですので、前回の時点以降で最初の該当データを採用するプログラムが目的です。説明が不十分で失礼しました。プログラム内容については、十分に中身を見て、参考にさせていただきます。本当にありがとうございました。