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

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

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

　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ
１　あ　　　田中　　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 回答日時： 2007/07/09 19:25

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

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の組み合わせが、自分で調べても全然分からずに苦労しておりました。
簡単な記述で出来るものなのですね。勉強になりました。

お礼日時：2007/07/10 09:58

No.3 回答者： imogasi 回答日時： 2007/07/09 22:06

例データ（質問のまま）

ＡＢＣＤ
あ田中2000N3
い中嶋1500Q3
う吉田1600U3
え石川1800N11
お横山1500Q11
か鈴木1600U11
き中村2500N19
く山田1200Q19
け橋本1400U19
ーーー
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列のみ）
あいう
田中中嶋吉田
200015001600
・・・
＃１のご回答と別のコードを考えました。

この回答へのお礼

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

お礼日時：2007/07/10 10:08

No.2 回答者： Wendy02 回答日時： 2007/07/09 21:33

こんばんは。

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

この回答へのお礼

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

お礼日時：2007/07/10 10:03