エクセルマクロでVLOOKUPのよう列を貼る

質問

初めましてよろしくお願いします。
シート２に
　　　　　　A　　　　　B　　　　　・・・・・・・・・　　　Z
１　　　９００　　　　　５　　　　　　　　　　　　　　　５
・　　　９０３　　　　　４０　　　　　　　　　　　　　　６０
・　　　　・　　　　　　　・　　　　　　　　　　　　　　　・
３００　２２０　　　　　１　　　　　・・・　　　　　　　　１００
３０１　２１０　　　　　１０　　　　・・・　　　　　　　　１０００　　
３０２　２００　　　　　１５　　　　・・・　　　　　　　　　２０
・
・
・
が有ります。シート１のE１０に２１０と入力されている場合、マクロを実行するとA列を検索し、シート２のA301の値と一致する３０１行をシート１のＥ１１から列に変換しコピーされるようにしたいと思います。
シート１結果
　　　A　　　　　B　　　　　C　　　　　D　　　　　Ｅ
１
２
・
・
１０　　　　　　　　　　　　　　　　　　　　　　　　２１０
１１　　　　　　　　　　　　　　　　　　　　　　　　　１０
・　　　　　　　　　　　　　　　　　　　　　　　　　　　・
・　　　　　　　　　　　　　　　　　　　　　　　　　　　・
３５　　　　　　　　　　　　　　　　　　　　　　　　１０００
　解る方、よろしくお願いします。

回答No.4

hallo-2007 · ベストアンサー

せっかくVlookup関数で答えが得られるのであれば
E11セルに
=VLOOKUP(E$10,Sheet2!A:Z,ROW(E2),FALSE)
と入れて下までコピーすると回答が得られます。
そこで　マクロの記録を実行すると
Activecell.FormulaR1C1 = _
"=VLOOKUP(R10C,Sheet2!C[-4]:C[21],ROW(R[-9]C[0]),FALSE)"
というコードが得られます。
ならば
Sub Macro1()
Range("E11:E35").Select
Selection.FormulaR1C1 = "=VLOOKUP(R10C,Sheet2!C[-4]:C[21],ROW(R[-9]C),FALSE)"
End Sub
とすればVBAで実行されます。数式でなく値が必要であれば
Sub Macro1()
With　Range("E11:E35")
　.FormulaR1C1 = "=VLOOKUP(R10C,Sheet2!C[-4]:C[21],ROW(R[-9]C),FALSE)"
　.Copy
　.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
End Sub

と範囲をコピーして　値にして貼り付けます。

お礼

回答ありがとうございます。うまくできました。ありがとうございました。

回答No.3

keithin

標準的なエラー処置込みで，探して転記するだけならごくシンプルに。

sub macro1()
　dim c as range
　dim d as range

　set d = worksheets("Sheet1").range("E10")
　set c = worksheets("Sheet2").range("A:A").find(what:=d.value, lookin:=xlvalues, lookat:=xlwhole)

　if c is nothing then exit sub
　d.resize(26, 1).value = application.transpose(c.resize(1, 26).value)
end sub

お礼

回答ありがとうございます。うまくできました。ありがとうございました。

回答No.2

merlionXX

一例です。

Sub test01()
　　Dim ws(1 To 2) As Worksheet
　　Dim myC As Range
　　Set ws(1) = Sheets("Sheet1")
　　Set ws(2) = Sheets("Sheet2")
　　Set myC = ws(2).Columns("A:A").Find(What:=ws(1).Range("E10"), LookAt:=xlWhole)
　　myC.Offset(, 1).Resize(, 25).Copy
　　ws(1).Range("E11").PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　Application.CutCopyMode = False
End Sub

お礼

回答ありがとうございます。うまくできました。ありがとうございました。

回答No.1

tom04

こんにちは！
ごく単純に・・・

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 26
If ws1.Cells(10, 5) = ws2.Cells(i, 1) Then
ws1.Cells(Rows.Count, 5).End(xlUp).Offset(1) = ws2.Cells(i, j)
End If
Next j
Next i
End Sub

標準モジュールにコピー＆ペーストしてマクロを実行してみてください。
こんな感じで良いのですかね？

お礼

回答ありがとうございます。うまくできました。ありがとうございました。