ｖｂａ 2つの条件が一致したらコピーして別シートに値のみ貼り付け

ｖｂａ初心者です。
ネットで「ｖｂａ複数条件一致」で検索して色々なものを見て自分なりにやってはいるのですが、どうしても思い通りにいきません。
お助けいただけると嬉しいです。

ｓｈｅｅｔ1にデータがあります。ｓｈｅｅｔ1のＡ列とＢ列がｓｈｅｅｔ2の（Ｂ2とＣ2）と一致した場合のみ、その行のＡ列～Ｄ列をコピーしてｓｈｅｅｔ2に貼り付けを行います。ｓｈｅｅｔ1の値は寸法・材料・日付の順に並んでおり、間に他の寸法が混ざることはありません。
貼付はｓｈｅｅｔ2のＢ列の6行目から行いたいです。行数は6行目から20行目までです。21行目以上になることはありません。
ｓｈｅｅｔ2の表はフォントの大きさ等を予め調整しているので、貼り付けは値のみとしたいです。
添付画像の左側がｓｈｅｅｔ１で右側がｓｈｅｅｔ2です。
添付画像の場合、ｓｈｅｅｔ2の「Ｂ6～Ｅ8」の部分がｓｈｅｅｔ1からコピーしたデータとなります。

No.1 ベストアンサー 回答者： tom04 回答日時： 2018/05/11 21:35

こんばんは！

関数でもできそうですが、VBAでの方法をご希望なのですよね。
一例です。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, lastRow As Long
Dim cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
If lastRow > 3 Then
Range(wS.Cells(6, "B"), wS.Cells(lastRow, "E")).ClearContents
End If
cnt = 5
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then
cnt = cnt + 1
wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value
End If
Next i
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

早速のご回答ありがとうございます。
標準モジュールで試してみたら無事うまくいきました。

ネットで調べながら少しずつ勉強してはいるのですが、まだまだうまくいかないことの方が多いです。
毎週末ネットで検索しながら試行錯誤していてうまくいかなかったことが、こんなに早く解決して驚いています。

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

お礼日時：2018/05/11 21:53

No.2 回答者： runix2007 回答日時： 2018/05/11 21:53

Sub 抽出()

Dim ws1, ws2, Sunpo, Zairyo
Dim StartRow, EndRow, tmpRow

'sheet名を変えている場合は適宜変えてください
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
'シート２に指定されている抽出寸法と材料です
Sunpo = ws2.Cells(2, "B")
Zairyo = ws2.Cells(2, "C")

StartRow = 2
EndRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
tmpRow = 6

For i = StartRow To EndRow
If (ws1.Cells(i, "A") = Sunpo) And (ws1.Cells(i, "B") = Zairyo) Then
ws2.Cells(tmpRow, "B") = Sunpo
ws2.Cells(tmpRow, "C") = Zairyo
ws2.Cells(tmpRow, "D") = ws1.Cells(i, "C")
ws2.Cells(tmpRow, "E") = ws1.Cells(i, "D")
tmpRow = tmpRow + 1
End If
Next

End Sub

この回答へのお礼

ご回答ありがとうございます。
標準モジュールで実行したらうまくいきました。

同じ結果を導くのに、いろいろなプログラムがあるなと感心させられます。
教えてｇｏｏの回答者さんは親切な方ばかりでとても感謝です。

本当にありがとうございます。

お礼日時：2018/05/11 22:04