VBAで別ブックの列を検索し、該当があれば行ごと新規ブックにコピーしたい。

Excel2013、マクロで複数の動作を行いたいのですが、以下の部分のみ完成しません。

お知恵をお借りできれば幸いです。

・book1のB列に「123」等の登録番号が不特定行続いている
・book2のC列に上記の登録番号が使用日順に並んでいる。
使用毎に追加のため順番はバラバラ、同じ番号が何度も出てくる

↑
この状態で、B列の番号をC列の上から検索していって、同番号がヒットした一番最初の行ごと新規ブック(book3）にコピーし、
B列の次の番号を再度C列の上から検索していき、ヒットすればその行をbook3の下にコピーし……
という事をして行きたいです。

B列の番号は、C列で一度ヒット＆コピーすれば、それ以降は検索せず次の番号へと移ります。
ここに至るまでの他マクロの動作は上手く行ったのですが、この部分のみ色々と調べてみても動作するものが出来上がりません。
どういった構文を使えばいいか等でもご教授頂ければ幸いです。

どうぞよろしくお願い致します。

質問者からの補足コメント

• ご回答ありがとうございます。
  大変申し訳ありません、説明が不足しておりました。
  >>・book2のC列に上記の登録番号が使用日順に並んでいる。
  >このC列の重複を取り去れば、それで、そのままつかえないでしょうか。
  ↑
  book1B列の登録番号種類数＝book2C列の登録番号種類数となっておりません。
  book2の方が原本で、book1はそのうちの幾つかを抜き出し、「このbook1内にある登録番号の最新使用日を調べろ」という命令での作業といった感覚になります。
  
  >B列に重複がないという前提ですが、その上で、C列に現れていないものは、リストには省くものが出てくるのでしょうか。
  B列に重複はございません。基本的にはB列にある番号はC列にありますが、人ごく稀にB列にありC列に無い番号が出ます。
  
  実際のマクロまで提示して頂き、誠にありがとうございます。こちらを一度組み込んでみたく思います。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/02/06 00:27

No.3 回答者： TH69 回答日時： 2017/02/12 23:20

book1のB列にある登録番号がbook2のC列にあれば、その行を新規ブックにコピーしたいということですね。

ws1=Book1.xlsmのSheet1
ws2=Book2.xlsxのSheet1
ws3=新規ブックのSheet1
a=ws1の最終行番号
b=ws2の最終行番号
c=ws2の最終列番号（表全体の最終列番号を取得しています）
d=ws3の転記開始行番号
e=ws2のC列チェック数のカウンタ
としています。

新規ブックを開き、そのSheet1をws3とします。

まずws1のB列i行目をws2のC列j行目と総当たりで確認します。
ws1のB列i行目の値がws2のC列j行目と同じだったら
ws3のd行目にws2のj行A列からc列の値を転記します。
転記したらd=d+1(次に転記する行）とし
ループを終了して、次に進みます。

同じでなかったらe=e+1とし、見つからなかった時には
ws1.Cells(i, "B").Value & "が見つかりません"と表示し、
次に進みます。

Sub test()

Dim a, b, c, d, e, i As Long, j As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
Set ws2 = Workbooks("Book2.xlsx").Worksheets("Sheet1")
a = ws1.Cells(Rows.Count, "B").End(xlUp).Row
b = ws2.Cells(Rows.Count, "C").End(xlUp).Row
c = ws2.Range("A1").CurrentRegion.Columns.Count
d = 1
Workbooks.Add
Set ws3 = ActiveWorkbook.Worksheets("Sheet1")
ws1.Activate

For i = 2 To a
e = 0
For j = 2 To b
If ws1.Cells(i, "B").Value = ws2.Cells(j, "C").Value Then
ws3.Cells(d, "A").Resize(1, c).Value = ws2.Cells(j, "A").Resize(1, c).Value
d = d + 1
Exit For
Else
e = e + 1
End If
Next j
If e = b - 1 Then
MsgBox ws1.Cells(i, "B").Value & "が見つかりません", vbExclamation
End If
Next i

End Sub

No.2 回答者： ExcelDevTool 回答日時： 2017/02/12 09:25

No.1 回答者： WindFaller 回答日時： 2017/02/05 22:57

こんばんは。

>・book2のC列に上記の登録番号が使用日順に並んでいる。
このC列の重複を取り去れば、それで、そのままつかえないでしょうか。Book3 に貼り付けてもよいのではありませんか？
データ・タブのデータツールの重複の削除の記録マクロを使うか、マクロのDictionary Objectで、重複を取り去ってしまうか、それだけなのですが、それを、book1との照合をするとか必要なのですか。

もし、照合を必要とする場合は、やり方をまったく変えて、

>B列の番号をC列の上から検索していって、
というのは、B列に重複がないという前提ですが、その上で、C列に現れていないものは、リストには省くものが出てくるのでしょうか。
そうすると、ちょっと複雑だなって思います。
ワークシート関数のCountIfで、Book2 のC列を検索して、C列に登場しないものを拾わず、そのまとまったものを、Book3 に貼り付けるという方法を考えました。

'照合を必要とする場合

Sub CheckNumberList()
Dim rng1 As Range
Dim rng2 As Range
Dim Ary() As Variant
Dim i As Long, j As Long, c
With ThisWorkbook.Worksheets("Sheet1") 'BookA のSheet1
　Set rng1 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp))
End With
With Workbooks("BookC.xlsx").Worksheets("Sheet1")
　Set rng2 = .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
End With

For Each c In rng1
　If WorksheetFunction.CountIf(rng2, c.Value) > 0 Then
　　ReDim Preserve Ary(i)
　　 Ary(i) = c.Value
　　 i = i + 1
　End If
Next c
If i = 0 Then
　MsgBox "番号を収録できませんでした。", vbExclamation
　Exit Sub
End If
Workbooks.Add '新規ブック
ActiveWorkbook.ActiveSheet.Range("A1").Resize(i).Value = Application.Transpose(Ary)
End Sub