エクセル2007 VBA シート１に入力されている項目をシート２の中で

質問

エクセル2007 VBA シート１に入力されている項目をシート２の中で検索し、新規シートにコピーする方法についてです。
例）
シート１
Ａ　　　　　　　　Ｂ　　Ｃ
取引先名　品目Ｃ　数量
Ａ　　　　　　１－１　２５
Ｂ　　　　　　あ１２　　５
Ｃ　　　　　　Ｔ－８　１０
：　　　　　　　：　　　　：

シート２
Ａ　　　　　　　Ｂ　　　　Ｃ　　　　　　Ｄ　　　　Ｅ
得意先C　取引先名　製品名　　品目Ｃ　　数量
００１ 　　　(株)Ｂ　　　　ケーブル　あ１２　　１０
００２　　　　(株)Ａ　　　　箱　　　　　１－１　　２０
００２　　　　(株)Ａ　　　　箱　　　　　１－１　　　７
００２　　　　(株)Ａ　　　　箱　　　　　１－１　　　５
：　　　　　　　：　　　　　：　　　　　　：　　　　　：

上記の状態で、シート１の項目をシート２から検索します。
・取引先名は一部分でも一致するあいまい検索で、品目Ｃは完全一致で検索したいです。
・シート２には検索項目のデータが複数あるのですが、結果が一致する行を選択し新規シートにコピーペーストしたいです。

出来れば下記の処理も実行したいです。
＊シート１の数量を、シート２の１行目から順に検索したデータから計算して、シート１の数量に満たした分だけをコピーペーストしたいです。
　シート１の数量に満たさない場合も取り敢えずシート２にある分のデータをコピーペーストして、処理が終わったら不足している項目データに印をつける。

　取引先Ａの場合→数量が２０個と７個の行をコピーペーストする感じです。

グーグルで調べたのですが、調べ方が悪いのか最初から躓いてしまいました。
今回はコードを記入していなくてすみません。
サンプルコードありで教えていただけるととても助かります。よろしくお願いします。

回答No.2

myRange · ベストアンサー

やりたい処理のうちどの部分が分からないのでしょうか。
（１）一致したときの新規シートへのコピー方法
（２）数量オーバーの処理
（３）数量未満の処理
（４）何もかも分からない

上記（４）だとちょっと、、、、、ですが、
回答をヒントに勉強するということであればそれもありかと。

で、上記（４）だということでサンプル。
但し、必ず理解すること！

▲Sheet1の未使用のＤ列に、転記分の合計
　同じくＥ列に、”未満”のコメント表示

'----------------------------------------------
Sub Test()
Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim NewSht As Worksheet
Dim R1 As Long
Dim R2 As Long
Dim Kei As Double

Set Sht1 = Worksheets("Sheet1")
Set Sht2 = Worksheets("Sheet2")
Set NewSht = Worksheets.Add(after:=Worksheets(Worksheets.Count))

Sht2.Range("A1:E1").Copy NewSht.Range("A1")

For R1 = 2 To Sht1.Cells(Rows.Count, "A").End(xlUp).Row
　Kei = 0
　For R2 = 2 To Sht2.Cells(Rows.Count, "A").End(xlUp).Row
　　If Kei < Sht1.Cells(R1, "C") And _
　　　InStr(Sht2.Cells(R2, "B"), Sht1.Cells(R1, "A")) > 0 And _
　　　Sht1.Cells(R1, "B") = Sht2.Cells(R2, "D") Then
　　　　　Sht2.Cells(R2, "A").Resize(1, 5).Copy _
　　　　　　　NewSht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　Kei = Kei + Sht2.Cells(R2, "E")
　　End If
　Next R2

　Sht1.Cells(R1, "D") = Kei
　Sht1.Cells(R1, "E") = ""

　If Kei < Sht1.Cells(R1, "C") Then
　　　Sht1.Cells(R1, "E") = "未満"
　End If

Next R1

End Sub
'-----------------------------------------

以上です。

お礼

返信遅くなりすみません。
サンプルありがとうございました。とても勉強になりました。
こちらを参考にして、処理を追加して使わせていただきました。

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

回答No.1

minaraiexcel

少し最後の質問について理解できていませんので
一応、上の質問だけを作成してみました。

新規シート　⇒　シート3へコピーしています。
そこは、新規作成として変更して頂ければいいかと。

Sub test()
Dim Key1 As String, Key2 As String
Dim i As Integer

i = 1 '貼り付け先の行
With Worksheets(2)
For x = 2 To 30 'シート1の品目C
For Each v In .Range("D2:D30") 'シート2の品目C
Key1 = Cells(x, 1).Value '取引先名
Key2 = Cells(x, 2).Value '品目C

If v.Value Like Key2 Then
If InStr(.Cells(v.Row, 2), Key1) > 0 Then
v.EntireRow.Copy Worksheets(3).Cells(i, 1)
i = i + 1
End If
End If
Next v
Next x
End With

End Sub

お礼

返信遅くなりすみません。サンプルありがとうございました。
ベストアンサーについては、もう一人の方に質問の全ての処理が出来るサンプルを作成していただけましたので、そちらの方を選ばせていただきました。

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