マクロでコピーしたセルと同じ数だけコピーしたい

質問

最近マクロの作成を始めた初心者です。
以前もこちらで質問しながら、下のようなマクロを作成したのですが、
少し追加で設定をしたいと思います。
どうやったら以下の設定ができるのでしょうか。

作成済み
「集計」のシートに「123」「402」「4002」などのシートの同じ番地(C10:F12）のセルの内容をコピーしたい
その際、「集計」B3:B15に入力されているシート名のみ対象にしたい
最初は、「集計」F6を頭にして貼り付けたい
コピーは、前のコピー分の下に連なる形でコピーしたい

追加したい事
例：E列に「123」のシートのB2の内容、D列に「123」のシートのB3の内容を上の構文で追加したすべての行にコピーしたい
その下にも同じ条件で追加したい

例：●は様々な値です
　　「AB」や「あい」のように、コピーしたい
　A　B　●　●　●　●
　A　B　●　●　●　●
　A　B　●　●　●　●
　あ　い　●　●　●　●
　あ　い　●　●　●　●
　あ　い　●　●　●　●　

現在、作成済みの分

Sub test()
Dim sn As String
d = 6
For i = 3 To 15
If Worksheets("集計").Range("B" & i) <> "" Then
sn = Worksheets("集計").Range("B" & i)

Worksheets(sn).Range("C10:F12").Copy
Worksheets("集計").Range("F" & d + 1).PasteSpecial Paste:=xlValues, Transpose:=True
d = Worksheets("集計").Range("F65536").End(xlUp).Row

End If
Next i
End Sub

回答No.2

Sinogi · ベストアンサー

>教えていただいたコードを、Next iの後ろに追記しました。
>これ自体が間違っているかもしれませんが、うまくいきません。

はい。その位置では正しい動作はしません。
変数宣言は一般にコードの最初に固めます。作成済みコードでも変数宣言していますから、その前後に記述してください。

また、肝心のFor～Nextループは作成済みでの貼り付け後、最終行の更新前に実行するようにしてください。

>二つ作成していて、行列を入れ替えての貼り付けを試していた時の
>コードです（今回はないものとして考えていきたいと思います）
に対し、サンプルコードは繰り返し回数が一回多いはずです。調整してください。

お礼

アドバイスを参考に無事完成しました。
以下、修正後の記述です。
何度もありがとうございました。

Sub test()
Dim sn As String
Dim B2V, B3V, Rep

d = 6
For i = 3 To 15
If Worksheets("集計").Range("B" & i) <> "" Then
sn = Worksheets("集計").Range("B" & i)

Worksheets(sn).Range("C10:F12").Copy
Worksheets("集計").Range("F" & d + 1).PasteSpecial Paste:=xlValues

B2V = Worksheets(sn).Range("b2").Value
B3V = Worksheets(sn).Range("b3").Value

For Rep = 1 To 3
Worksheets("集計").Cells(d + Rep, 5).Value = B2V
Worksheets("集計").Cells(d + Rep, 4).Value = B3V
Next Rep

d = Worksheets("集計").Range("F65536").End(xlUp).Row

End If

Next i
End Sub

回答No.3

imogasi

マクロの記録で判ることか、少し修正すればよいことでは。同じような質問を繰り返さないためにも、マクロの記録をとってどの部分を変えるべき（相対化すべき）か自分で考えてから質問すべきように思うが。

回答No.1

Sinogi

作成済みコードは希望の動きなんですか？
質問の内容と一部あっていません。

>Worksheets("集計").Range("F" & d + 1).PasteSpecial Paste:=xlValues, Transpose:=True
の　Transpose:=True　のことを指しています。

提示されたコードが正しいとしてサンプル提示します。

Dim B2V, B3V, Rep

B2V = Worksheets(sn).Range("b2").Value
B3V = Worksheets(sn).Range("b3").Value
For Rep = 1 To 4
Worksheets("集計").Cells(d + Rep, 5).Value = B2V
Worksheets("集計").Cells(d + Rep, 4).Value = B3V
Next Rep

どこに追記するかは自分で考えてください

補足

>質問の内容と一部あっていません。

すいません。
二つ作成していて、行列を入れ替えての貼り付けを試していた時の
コードです（今回はないものとして考えていきたいと思います）

教えていただいたコードを、Next iの後ろに追記しました。
これ自体が間違っているかもしれませんが、うまくいきません。

結果
空白　空白　●　●　●　●
空白　空白　●　●　●　●
空白　空白　●　●　●　●
空白　空白　●　●　●　●
空白　空白　●　●　●　●
空白　空白　●　●　●　●
あ　　い
あ　　い
あ　　い

入力したい上のリスト部分には空白のみで、何も入りません。
リストが終わった下部にのみコピーされます。