VBA 特定の行を別シートへコピー・削除

質問

下記のように、VBAで特定の行を抽出して別シートへコピーし、コピーした行については元リストデータを削除したいです。
具体的には、【出荷sheet】（C列注文番号は、出荷があった時に入力済）へ、注文番号に対応する行を【リストsheet】から抜き出してコピーし、コピー後は、【リストsheet】から該当行を削除したいです。
検索により調べてもうまく合致する回答が見当たらず困っています。
VBAの理解度は未熟ですが、何卒ご教授いただけると幸いです。

【リストsheet】
A列　B列　　C列　　　D列　・　・　・　Ｊ列
No.　日付　注文番号 　品名　・　・　・　・
1　　1/1 　 A111　　 鉛筆 　・　・　・　・ ←コピー後、削除　
2　 　1/2 　 B222　　 ペン　 ・　・　・　・
3　 　 1/5 　C555 消しゴム・　・　・　・ ←コピー後、削除　
・
・
　　⇓
【出荷Sheet】
A列　B列　　C列　　　D列　・　・　・　Ｊ列
No.　日付　注文番号 　品名　・　・　・　・
1　　1/1 A111　　 鉛筆 　 ・　・　・　・
3　　 1/5 　 C555 消しゴム・　・　・　・

回答No.2

ushi2015 · ベストアンサー

こんにちは
出荷sheetのシートタブを右クリックして「コードの表示」でVBE画面を出して、
下記コードを貼り付けて下さい。
C列に注文番号を入力すると処理が走ります。
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim s As Worksheet
　　Dim a As Variant
　　Dim r As Range
　　If Target.Count > 1 Then Exit Sub
　　If Target.Column <> 3 Then Exit Sub
　　If Target.Value = "" Then Exit Sub

　　Set s = Worksheets("リストsheet")
　　With s
　　　　Set r = .Range("C1", .Range("C" & Rows.Count).End(xlUp))
　　　　a = Application.Match(Target.Value, r, 0)
　　　　If IsError(a) Then
　　　　　　MsgBox "入力注文番号が有りません。", vbExclamation
　　　　Else
　　　　　　Application.ScreenUpdating = False
　　　　　　Application.EnableEvents = False
　　　　　　.Range("A" & a).Resize(, 10).Copy Target.EntireRow.Cells(1, 1)
　　　　　　.Range("A" & a).EntireRow.Delete
　　　　　　Application.EnableEvents = True
　　　　　　Application.ScreenUpdating = True
　　　　End If
　　End With
End Sub
テストブックで試して下さい。
出荷sheetのC列はデータの入力規則でリストsheetのC列の注文番号を選択出きるように
しておくといいかと思います。

お礼

早速ご回答いただきましてありがとうございました。
コピー＆ペーストしたら正常に進みました。
マクロボタンを作成しなくとも自動で実行される方法もあるとは、驚きでした。しかも、エラー時にメッセージボックス表示までされるようにしていただき、こちらの意図を汲み取っていただき、本当にすごい方だと感謝の念が尽きません。自分の勉強不足を痛感したので、もっと勉強したいと思います。

回答No.3

Prome_Lin

私なりの回答です。

Option Explicit
Sub Test()
Dim s1, s2 As Worksheet
Dim i As Integer
Dim f As Range
Set s1 = Worksheets(1)
Set s2 = Worksheets(2)
For i = 2 To s2.Range("C2").End(xlDown).Row
Set f = s1.Range(s1.Cells(2, 3), s1.Cells(s1.Range("C2").End(xlDown).Row, 3)).Find(s2.Cells(i, 3).Value)
s1.Rows(f.Row).Copy s2.Cells(i, 1)
s1.Rows(f.Row).Delete
Next i
End Sub

簡単な説明。

「Worksheet(1)」（左端のシート）を、「s1」とセット、同じく「Worksheets(2)」を「s2」としてセット。

「Worksheets(2)」の「C」列の２行目からデータのある最終行（ここでいう最終行とは、空白があるまで、なので、途中に空白があれば、そこで止まってしまいます。従って、「注文番号」は連続して入力してある必要があります。）まで１行ずつ処理。

「Worksheets(2)」の「注文番号」を使って、「Worksheets(1)」の「注文番号」を検索（Find）。

見つかった行（f.Row）をコピー（記憶）し、「Worksheets(2)」にペースト。

「Worksheets(1)」のその行を削除。

以上です。

お礼

ご回答ありがとうございました。
簡潔な表示かつご丁寧な説明までしていただき有難うございます。
私自身の理解の浅さを反省し、もっと勉強したいと思います。

回答No.1

kkkkkm

それぞれのシート名は表の参考に記載されているシート名にしています。
データは質問に書かれた状態で2行目からデータがあるものとしています。
リストsheetの注文番号に重複があった場合、下にあるものがコピーされます。
出荷Sheetの注文番号に重複があった場合、同じものがコピーされます。

最後に削除する行を選択するようにしてますので、正常に動作したらSelect をDeleteにしてください。
Sub Example()
Dim ListData As Variant, SearchData As Variant
Dim i As Long, j As Long
Dim TargetRows As String
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("リストsheet")
Set ws2 = Sheets("出荷Sheet")
ListData = ws1.Range(ws1.Cells(2, "C"), ws1.Cells(Rows.Count, "C").End(xlUp))
SearchData = ws2.Range(ws2.Cells(2, "C"), ws2.Cells(Rows.Count, "C").End(xlUp))
TargetRows = ""
For i = LBound(SearchData) To UBound(SearchData)
For j = LBound(ListData) To UBound(ListData)
If ListData(j, 1) = SearchData(i, 1) Then
TargetRows = TargetRows & j + 1 & ":" & j + 1 & ","
ws1.Range(ws1.Cells(j + 1, "A"), ws1.Cells(j + 1, "J")).Copy ws2.Cells(i + 1, "A")
End If
Next j
Next i
TargetRows = Left(TargetRows, Len(TargetRows) - 1)
ws1.Activate
ws1.Range(TargetRows).Select 'Delete
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

お礼

早速、ご丁寧にご回答いただきまして、ありがとうございました。
前提が抜けている箇所があり、申し訳ございませんでした。
コピー＆ペーストしたら、正常に起動しました！感謝です。
まだまだ勉強不足であることを痛感しました。。。