エクセルのVBAで教えて下さい。

質問

エクセルVBAで以下の方法のマクロが分からず、教えて頂きたいです。

まず、ブックAのシートAがあり、シートAのセルD3には号機No.を入力します（999などの数値のみ）

次にブックBのシートBがあり、このシートのD列にも号機No.が入力されています。

やりたい事はブックAのシートAのD3に号機No.を入力したら、ブックBのシートBのD列から同じ号機No.を
探し、当てはまる号機の行のI列、J列、K列、L列、M列をコピーし
ブックAのシートAのF13、F14、F15、F16、F17、に貼り付けたいです。
それぞれの貼り付け先は
K列⇒F13　L列⇒F14　M列⇒F15　I列⇒F16　J列⇒F17のようになります。

それとブックBのシートBのD列に入力されている号機No.は同じ数値が入力されている時があります。
この場合は必ず下にある号機No.のが最新ですので、そちらを読み取るようにしたいです。
例えば、4行目と8行目に同じ号機No.がある場合は8行目の方を読み取る。

現在は　GYOU = Application.InputBox　でターゲットの行番号を入力して
その行の列をコピー・ペーストしている感じです。

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Dim tmp() As String
If Intersect(Target, Range("D3")) Is Nothing Then
Exit Sub
Else
End If

Dim buf As String
Dim j As Integer
Dim GYOU As String
Set xCur = Selection

Dim OpenFileName As String
Workbooks.Open Filename:="業務都合の為載せれません"

GYOU = Application.InputBox("行を選択してください", "行指定")

'<キャンセルの場合、処理を終わりにします。>
If GYOU = "False" Then Exit Sub

For j = 11 To 11
ActiveSheet.Cells(GYOU, j).Copy
ThisWorkbook.ActiveSheet.Cells(13, 6).PasteSpecial Paste:=xlPasteValues
Next j
For j = 12 To 12
ActiveSheet.Cells(GYOU, j).Copy
ThisWorkbook.ActiveSheet.Cells(14, 6).PasteSpecial Paste:=xlPasteValues
Next j
For j = 13 To 13
ActiveSheet.Cells(GYOU, j).Copy
ThisWorkbook.ActiveSheet.Cells(15, 6).PasteSpecial Paste:=xlPasteValues
Next j
For j = 9 To 9
ActiveSheet.Cells(GYOU, j).Copy
ThisWorkbook.ActiveSheet.Cells(16, 6).PasteSpecial Paste:=xlPasteValues
Next j
For j = 10 To 10
ActiveSheet.Cells(GYOU, j).Copy
ThisWorkbook.ActiveSheet.Cells(17, 6).PasteSpecial Paste:=xlPasteValues
Next j

ActiveWorkbook.Close SaveChanges:=False

With xCur
.Parent.Parent.Activate '元のブックへもどる
.Parent.Activate '元のシートへもどる
End With

End Sub

ど素人の為、めちゃくちゃな並びだとは思いますが一応現在の状態のマクロを載せておきます。

御指導の程、宜しくお願いします。

回答No.1

keithin · ベストアンサー

もっといろいろシンプルに

private sub Worksheet_Change(byval Target as excel.range)
　dim w as workbook
　dim c as range

　if application.intersect(target, range("D3")) is nothing then exit sub
　if range("D3") = "" then exit sub

　application.calclation = xlcalculationmanual
　application.screenupdating = false

’転記元のブックを開いて逆順で検索する
　set w = workbooks.open("c:test\book1.xls")
　set c = w.worksheets("シートＢ").range("D:D").find(what:=range("D3").value, lookin:=xlvalues, lookat:=xlwhole, searchdirection:=xlprevious)

’見つけた（一番下の）セルを基準に転記する
　if not c is nothing then
　　range("F13").value = c.offset(0, 7).value
　　range("F14").value = c.offset(0, 8).value
　　range("F15").value = c.offset(0, 9).value
　　range("F16").value = c.offset(0, 5).value
　　range("F17").value = c.offset(0, 6).value
　end if
　w.close false

　application.screenupdating = true
　application.calclation = xlcalculationautomatic

end sub

みたいな。

お礼

まさに完璧なマクロでした。
非常に助かりました。
ありがとうございました。
ベストアンサーとさせて頂きます。