複数回コピーした後、更にコピー

Question

前提・実現したいこと

縦23列、横52行の表があり、1行余白を作り最初にn回縦にコピー。
nの回数はinputで入力できる形式にする予定です。
次にn回縦にコピーされた最終行を求め、1列余白を作り右側にコピーしたいと思っています。

イメージとしてはA1からV52*nの最終行を求めてコピーするイメージです。

追記
縦23列、横52行の表には複数個数式が入っています。
それを消さずにコピーペーストを行いたいです。

発生している問題・エラーメッセージ

縦のコピーが現状どうにもならない形です。
そもそもforでいけるのかという疑問も出てきます

実行時エラー438
オブジェクトは、このプロパティまたはメソッドをサポートしていません。

該当のソースコード

Sub prot()

    '人数を入力
    Dim math As Long
    math = InputBox("人数を入力してください")
    
    
    '表のコピー
    Set D = Range("A1:W52")
    D.Select
    Selection.Copy
    
    '縦コピー
    C = 53
    For j = 1 To math Step 53
        Worksheets(1).Range("A" & C) = D.Paste
        C = C + 53
    Next j
    
    cel_cnt = 53
    MaxCol = Worksheets(1).Cells(Rows.Count, 23).End(xlUp).Row
    
    For i = 1 To MaxCol Step 53
        Worksheets(1).Range("A1" & ":" & "W" & cel_cnt).Copy Worksheets(1).Range("X1" & ":" & "AS" & cel_cnt)
    Next i

    MsgBox "ok"
End Sub

試したこと

Rangeオブジェクトを取り除いてみましたが、結果的にダメでした。

Answer 1

    '縦コピー
    C = 53
    For j = 1 To math Step 53
        Worksheets(1).Range("A" & C) = D.Paste 
        C = C +  53
    Next

1行開けるなら、C=54

Step 53 したら1ループで53増えるので、InputBox で53以上入力しないと1回しか実行されない。Step 53 は不要。

Worksheets(1).Range("A" & C) = D.Paste
このようなコマンドはない。指定位置に貼り付けは、下記で。
Range("A" & c).PasteSpecial xlPasteAll

    For i = 1 To MaxCol Step 53
        Worksheets(1).Range("A1" & ":" & "W" & cel_cnt).Copy Worksheets(1).Range("X1" & ":" & "AS" & cel_cnt)
    Next i

縦に複数回複製して全体を横にコピーしたいのなら、ループする必要はない。上と同様にStepの使い方も間違っている。下記の1行で全体をコピーできる。

    Worksheets(1).Range("A1" & ":" & "W" & MAXCOL).Copy Range("Y1")

あとは、Worksheets(1). があったり、なかったり統一されていないのを修正して、無駄なSelectを省略すると下記のようなコードになります。

Sub prot()

    '人数を入力
    Dim math As Long
    math = InputBox("人数を入力してください")

With Worksheets(1)    
    '表のコピー
    .Range("A1:C2").Copy

    '縦コピー
    Dim c As Long
    c = 54
    Dim j As Long
    For j = 1 To math
        .Range("A" & c).PasteSpecial xlPasteAll
        c = c + 53
    Next j

    Dim MAXCOL As Long
    MAXCOL = .Cells(.Rows.Count, 23).End(xlUp).Row

    .Range("A1:W" & MAXCOL).Copy Range("Y1")
End With

    MsgBox "ok"
End Sub

Comments

[hatena19]

長々とコードを書いていたら先を越された(;^ω^)

[退会済みユーザー]

ご返答ありがとうございます。

参考までにお伺いしたいのですが、仮に元のデータ”A1からV52”に列幅の調整が行われていた場合、
xlPasteColumnWidthsではエラーがでたのですが、
オブジェクトは、このプロパティまたはメソッドをサポートしていません、と出るのですが
この場合の改善点としてはどのあたりになるのでしょうか

[jinoji]

PasteSpecial xlPasteColumnWidths を使えるのは、列全体をコピーしたときだと思います。

Range("A:W").Copy
Range("Y:AU").PasteSpecial xlPasteColumnWidths

私のコードに追記するなら、
c.EntireColumn.Copy
c.EntireColumn.Offset(, c.Columns.Count).PasteSpecial xlPasteColumnWidths

[退会済みユーザー]

ありがとうございます！

Answer 2

最後に右側に、というのがイメージがつかめなかったですが、
雰囲気こんな感じでしょうか。

Sub prot2()
    '人数を入力
    Dim math As Long
    math = InputBox("人数を入力してください")
    Dim d As Range, c As Range
    Set d = Range("A1:W52")
    Set c = d.Resize(d.Rows.Count + 1, d.Columns.Count + 1)
    c.Copy c.Resize(c.Rows.Count * (math + 1), c.Columns.Count * 2)
    MsgBox "ok"
End Sub

Comments

[退会済みユーザー]

ご返信ありがとうございます。

完璧です！