行抽出マクロについて教えてください。

質問

エクセルで
sheet1このように入力されております。
A列には製造番号　Ｂ列には日付　Ｃ列単価　Ｄ列記号がすでに入力済みです。
_____________________________________
行/列　 A 　　 B 　　 C 　　 D
1 　 123456 　 4/5 　 1020 　 K
2　　789456　 5/2 　 500 　　D
3　　789789 　 6/2 　 9000 　 F
4　　456789 　 6/2 　 5000 　 S
-------------------------------------
sheet2には製造番号が500行ランダムに入力済みです。
_____________________________________
行/列　 d 　　 E 　　 F 　　 G
2 　 456789
3　　789456　
4　　789789
5　　456789
6 　　 ：
7　　　：
-------------------------------------
ボタンをおしたら一致した製造番号のEFG列にsheet1の日付・単価・記号を自動的に入力したい。どなたかご教授お願いいたします。

回答No.1

pkh4989 · ベストアンサー

以下のマクロで試してみてください。

Sub test()
　　Dim vData　　　 As Variant
　　Dim mR1　　　　 As Long
　　Dim mR2　　　　 As Long
　　Dim wR　　　　　As Long
　　Dim wId　　　　 As Integer
　　'
　　With Worksheets("Sheet1")
　　　　mR1 = .Range("A" & Rows.Count).End(xlUp).Row
　　　　vData = .Range("A1:D" & mR1)
　　End With
　　With Worksheets("Sheet2")
　　　　mR2 = .Range("D" & Rows.Count).End(xlUp).Row
　　　　For wR = 1 To mR2
　　　　　　wId = Get_DataIdx(.Cells(wR, 4), vData)
　　　　　　If wId > 0 Then
　　　　　　　　.Cells(wR, 5) = vData(wId, 2)　'日付
　　　　　　　　.Cells(wR, 6) = vData(wId, 3)　'単価
　　　　　　　　.Cells(wR, 7) = vData(wId, 4)　'記号
　　　　　　End If
　　　　Next
　　End With
End Sub
'コード検索の位置を求める
Function Get_DataIdx(wCode As String, vData As Variant)
　　Dim wI　　　　　As Integer
　　'
　　Get_DataIdx = 0
　　For wI = 1 To UBound(vData)
　　　　If vData(wI, 1) = wCode Then
　　　　　　Get_DataIdx = wI
　　　　　　Exit For
　　　　End If
　　Next
End Function

お礼

とても勉強になりました。有難う御座いました。