値検索コピー他シートへ貼付け

質問

sheet1A3を選択して実行すると、
sheet2の表からa003を探し、隣のB5をコピーし、
sheet3の表でa003に該当するC3に縦書き（ふりがな付き）で貼り付ける。
またSheet1にもどり次にA4を選択して
同じようにSheet3E4に貼り付けていくようなマクロは組めるでしょうか？

回答No.2

googoo900

ちょっと長くなりましたが、こんな感じでしょうか？
例図が見づらかったので、忠実にできているかわかりません。
excel2007で確認。

Sub Macro1()

Dim col1, row1, endrow As Integer
Dim a1, a2 As Variant
Dim myRng As Range
Dim c1, c2 As Range

If ActiveSheet.Name <> "Sheet1" Then
MsgBox "Sheet1から実行してください"
Exit Sub
End If

'get selected cell
col1 = ActiveCell.Column
row1 = ActiveCell.Row
endrow = Cells(row1, col1).End(xlDown).Row

'
For i = row1 To endrow
Sheets("Sheet1").Select
a1 = Cells(i, col1)
If i = row1 And a1 = "" Then
MsgBox "選択したセルは空白でした"
Exit Sub
End If

'select sheet2
Sheets("Sheet2").Select

'search target cell
Set myRng = Range("A1", Cells(1, 1).SpecialCells(xlCellTypeLastCell))
For Each c1 In myRng
If c1.Value = a1 Then a2 = c1.Offset(0, 1).Value
Next c1

'select sheet3
Sheets("Sheet3").Select

'search target cell
Set myRng = Range("A1", Cells(1, 1).SpecialCells(xlCellTypeLastCell))
For Each c2 In myRng
If Cells(c2.Row, c2.Column) = a1 Then
c2.Offset(1, 0).Value = a2
c2.Offset(2, 0).Value = Application.GetPhonetic(a2)
Range(c2.Offset(1, 0), c2.Offset(2, 0)).Select
With Selection
.Orientation = xlVertical
End With
Exit For
End If

Next c2

Next i

'行高さ自動合わせ
Rows("3:4").RowHeight = 409.5
Rows("3:4").EntireRow.AutoFit

End Sub

お礼

回答ありがとうございます。
いろいろ修正はしてみましたが力量不足の為
Sheet3の表には貼付けできませんでした。
表が見づらいものと思います。
実際の表は、もうすこし複雑になっています。

回答者リクエスト機能はないようなので残念ですが
また新たに質問させていただきます。
見ていただければ幸いと思います。
ありがとうございました。

回答No.1

keithin

なぜシート３のＣ３が「ａ００３に該当」し、その次はシート３のＥ４にどうしてなるのかが不明である以外は、別にムズカシイことはなにもありません。新しいマクロの記録で参考マクロを録ってみることでも、ほとんどそのまま利用できます。
例えば下記のマクロを参考に、あなたの説明の抜けているところを自力で適切に補って作成してみてください。

sub macro1()
　dim h as range
　dim r as range
　dim target as range

　on error resume next
　set target = worksheets("Sheet3").range("C3")

　for each h in worksheets("Sheet1").range("A3:A" & worksheets("Sheet1").range("A65536").end(xlup).row)
　’シート１の対象セルを選択する
　　worksheets("Sheet1").select
　　h.select

　’シート２を調べ、転記する
　　target.value = worksheets("Sheet2").range("A:A").find(what:=h.value, lookin:=xlvalues, lookat:=xlwhole).offset(0, 1).value

　’シート３で縦書き振り仮名表示にする
　　target.orientation = xlvertical
　　target.setphonetic
　　target.phonetics.visible = true

　　set target = target.offset(1, 2)
　next
　worksheets("Sheet3").select
end sub

お礼

ご回答ありがとうございます。
結果うまくいきませんでした。
やはりSheet3の表に入れるのが難しいです。

また新たに質問させていただきます。
ありがとうございました。