ＶＢＡで検索してコピー

質問

エクセル2003を使っています。
下記のような構文で、あるデータを検索しています。
検索まではできましたが、その検索したデータが入力されている行を選択して別のシートにコピーしたいです。

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng As Range

Set ws1 = Sheets("CSV") '検索先のシート
Set ws2 = Sheets("0群加工") '検索データのシート
Set ws3 = Sheets("完了") '貼付先シート
Set ws4 = Sheets("過程")
With ws1.Columns("A") '完全一致でシートの頭から検索（A列）
i = 2

Do Until ws2.Cells(i, "E").Value = "" 'ws2のデータがなくなるまで
Set rng = .Find(What:=ws2.Cells(i, "E").Value, LookAt:=xlPart, After:=.Cells(.Cells.Count)) '検索

上記は0群加工シートに入力されているデータを、CSVシートに入力されているデータを検索しています。
（ここのデータというのは時間が入力されています。つまり、0群シートに入力されている時間と同じ時間を、CSVシートで検索しています）
CSVシートに同じデータがあれば、そのデータがあるセルが属する行をコピーして、違うシートに貼り付けたいです。

よろしくお願いします。

回答No.2

merlionXX · ベストアンサー

自分でもテストしてみましたが、時刻の検索はお互いの書式の表示形式がちがうと難しいようです。
両者の時刻の表示形式を統一し、コードも以下のように変えてみてください。

Sub test02()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng As Range
Set ws1 = Sheets("CSV") '検索先のシート
Set ws2 = Sheets("0群加工") '検索データのシート
Set ws3 = Sheets("完了") '貼付先シート
With ws1.Columns("A") 'A列を頭から検索
i = 2
Do Until ws2.Cells(i, "E").Value = "" 'ws2、E2以下のデータがなくなるまで
Set rng = .Find(What:=ws2.Cells(i, "E").Text, LookAt:=xlWhole, After:=.Cells(.Cells.Count)) '検索
If Not rng Is Nothing Then 'あれば
n = n + 1 '貼り付け先行カウント
rng.EntireRow.Copy ws3.Cells(n, "A") '行のコピペ
End If
i = i + 1 '検索データ行カウント
Loop
Set rng = Nothing
End With
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub

お礼

前回に引き続き、ご回答頂きありがとうございます。
merlionXX様のお陰様で、上手く行きました。

前回との違いは、
前回は、0群加工シートのデータをコピーしたかったのですが、今回はCSVシートにあるデータが属する行をコピーしたかったので、質問させて頂きました。

ありがとうございました。

回答No.1

merlionXX

先日ご質問の　http://okwave.jp/qa4840846.html といったい何がちがうのでしょうか？
Sheets("0群加工") E列2行目以下にある時間データを、Sheets("CSV") のA列から検索し、完全一致でヒットしたSheets("CSV") の行をコピーし、Sheets("完了") の1行目から順に貼り付ければいいのですね？
時間データなので、標示の書式がいろいろあると思いますが、Sheets("0群加工") Sheets("CSV") ともに"h:mm"形式としていますが、違っていたら直してください。

Sub test01()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng As Range
Set ws1 = Sheets("CSV") '検索先のシート
Set ws2 = Sheets("0群加工") '検索データのシート
Set ws3 = Sheets("完了") '貼付先シート
With ws1.Columns("A") 'ws1、A列を頭から検索
i = 2
Do Until ws2.Cells(i, "E").Value = "" 'ws2、E2以下のデータがなくなるまで
Set rng = .Find(What:=Format(ws2.Cells(i, "E").Value, "h:mm"), LookAt:=xlPart, After:=.Cells(.Cells.Count)) '検索
If Not rng Is Nothing Then 'あれば
n = n + 1 '貼り付け先行カウント
rng.EntireRow.Copy ws3.Cells(n, "A") '行のコピペ
End If
i = i + 1 '検索データ行カウント
Loop
Set rng = Nothing
End With
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
End Sub