エクセルのマクロでセルに入力されているセル番地に貼り付け？

質問

エクセルのマクロで質問です。

下記のように入力されています

　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ
１　あ　　　田中　　2000　　N3　　
２　い　　　中嶋　　1500　　Q3
３　う　　　吉田　　1600　　U3
４　え　　　石川　　1800　　N11
５　お　　　横山　　1500　　Q11
６　か　　　鈴木　　1600　　U11
７　き　　　中村　　2500　　N19
８　く　　　山田　　1200　　Q19
９　け　　　橋本　　1400　　U19
・・・・（500行くらいあります）

この表のA1:C1をN3に行列を入換えて貼り付け、
A2:C2をQ3に行列を入換えて貼り付け・・・
のように、ABC列の内容を、D列に入力されているセル番地に貼り付けたいのです。
INDIRECT関数など使ってみましたが、どうにも出来そうにありません。
これをなんとかマクロで出来ないものでしょうか。
困ってます。お願いします。

回答No.1

zap35 · ベストアンサー

例えばこんなマクロでしょうか？

Sub Macro2()
Dim idx As Long
　On Error Resume Next
　For idx = 1 To Range("A65536").End(xlUp).Row
　　Cells(idx, "A").Resize(1, 3).Copy
　　Range(Cells(idx, "D")).PasteSpecial , Transpose:=True
　Next idx
　Application.CutCopyMode = False
End Sub

お礼

早速のご回答ありがとうございます。
Rangeとcellsの組み合わせが、自分で調べても全然分からずに苦労しておりました。
簡単な記述で出来るものなのですね。勉強になりました。

回答No.3

imogasi

例データ（質問のまま）
Ａ Ｂ Ｃ Ｄ
あ 田中 2000 N3
い 中嶋 1500 Q3
う 吉田 1600 U3
え 石川 1800 N11
お 横山 1500 Q11
か 鈴木 1600 U11
き 中村 2500 N19
く 山田 1200 Q19
け 橋本 1400 U19
ーーー
VBAコード
標準モジュールに
Sub test01()
i = 2
Do While Cells(i, "D") <> ""
Sheets("Sheet1").Range(Cells(i, "D")) = Cells(i, "A")
Sheets("Sheet1").Range(Cells(i, "D")).Offset(1, 0) = Cells(i, "B")
Sheets("Sheet1").Range(Cells(i, "D")).Offset(2, 0) = Cells(i, "C")
MsgBox "AA"
i = i + 1
Loop
End Sub
ーー
結果（初めの３つN,O,U列のみ）
あ い う
田中 中嶋 吉田
2000 1500 1600
・・・
＃１のご回答と別のコードを考えました。

お礼

前回に続いてご回答いただきありがとうございます。
変数の範囲にしても色々な方法があるものですね。
いつも勉強になります。
（申し訳ないですが、お礼ポイントは時間の早かった方から付けさせていただきました）

回答No.2

Wendy02

こんばんは。

INDIRECT でも出来そうな気がするのですが、やはりややこしいかもしれません。

以下は、D列の表示は無視して貼り付けるものと、D列の表示よるものと両方を作ってみました。コメントブロック（'）を入れ替えれば、アドレス表示による貼り付けになります。

Sub ChangePlacement()
Dim ar As Variant
Dim i As Long
Dim Cols As Variant
　Cols = Array(21, 14, 17) '列データ　'N,Q,U

　Application.ScreenUpdating = False
　With ActiveSheet
　For i = 1 To .Range("A65536").End(xlUp).Row
　　　ar = .Cells(i, 1).Resize(, 3).Value　'配列に差し替え
　　　.Cells(Int((i - 1) / 3) * 8 + 3, Cols(i Mod 3)).Resize(3).Value _
　　　　 = WorksheetFunction.Transpose(ar)　'行列入れ替え
　　　'.Range(.Cells(i, 4).Value).Resize(3).Value = _
　　　 WorksheetFunction.Transpose(ar) 　'D列の表示による
　Next i
　End With
　Application.ScreenUpdating = True
End Sub

お礼

いつもお世話になります。ありがとうございます。
配列は私にはよく分からないのですが、やってみるとバッチリできますね。
この記述を見て勉強します。
（申し訳ないですが、お礼ポイントは時間の早かった方から付けさせていただきました）