シートのデータを29列おきにジャンプして別のシートに貼り付けて行きたい。

Question

VBAについて質問です。
下記のように、Summary　シートにある一部のデータを　SubSheetへ29列おきにジャンプして
貼り付けて行きたいと考えたコードですが、いつも決まったところで実行時エラーが出てしまいます。
何が悪いのかわかりません。どなたか助けて頂きたく。。。。

Sub transfer()
    Dim R As Variant
    Dim C As Variant
    
    For R = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For C = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 29
    For W = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 1
    Sheets("SubSheet").Range(Cells(R + 2, W), Cells(R + 2, W + 10)).Value = Sheets("Summary").Range(Cells(R + 2, C + 11), Cells(R + 2, C + 21)).Value　←　ココでエラー
    
    Next
    Next
    Next
    Worksheets("SubSheet").Activate
    Range("A1").Select
    Application.ScreenUpdating = True

End Sub

イメージ

”Summary”　シート　　　　　29列　　　　　　　　　　　　29列　　　　
　　A・・・　L　M　N　V  ・・・・・AM　AN　～　AW　・・・・・BN　～　BX　　　　　　
１　　　　　　データ有り　　　　　　　　データ有り　　　　　　　　　データ有り
２　　　　　　データ有り　　　　　　　　データ有り　　　　　　　　　データ有り　　　
・　　　　　　　　・　　　　　　　　　　　　・　　　　　　　　　　　　　・
・　　　　　　　　・　　　　　　　　　　　　・　　　　　　　                  ・
1000　　　　　データ有り　　　　　　　　データ有り　　　　     　　　データ有り

　　　　　　　　　　　　　　　　　　　　　↓　別のシートへ移動　　　　

”Sub Sheet”
　   A  B  C   D   ・F　G　H　I ・K　L　M　N　・　
１　　データ　　　　データ　　　　データ
２　　データ　　　　データ　　　　データ
３　　データ　　　　データ　　　　データ
・　　　・　　　　　　・　　　　　　・
・　　　・　　　　　　・　　　　　　・
1000　データ　　　データ　　　　　データ　

何卒よろしくお願いします。

tatsu99 · Accepted Answer

前回のは破棄してください。これでどうでしょうか。
--------------------------------------------------
Option Explicit
Sub transfer()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row1 As Long
Dim row2 As Long
Dim i As Long
Dim j As Long
Dim col1 As Long
Dim col2 As Long
Set sh1 = Worksheets("Summary")
Set sh2 = Worksheets("SubSheet")
Application.ScreenUpdating = False
For i = 0 To 25
    For j = 0 To 1469
        row1 = j + 30
        col1 = i * 30 + 8
        row2 = j + 3
        col2 = i * 11 + 1
        sh2.Range(sh2.Cells(row2, col2), sh2.Cells(row2, col2 + 9)).Value = sh1.Range(sh1.Cells(row1, col1), sh1.Cells(row1, col1 + 9)).Value
    Next
Next
Application.ScreenUpdating = True
sh2.Select
Range("A1").Select
MsgBox ("完了")
End Sub

tatsu99 · Answer

>仰るとおりです。
>構文とか何か必要なのですか？
要件が判りましたので、再度、マクロを修正したものを提示します。
こちらで、動作確認も行いますので、提示は、明日になるかも知れません。
しばらくお待ちください。

tatsu99 · Answer

すみません、画像がよく見えないのですが、
そうすると、以下のように、ブロック単位でコピーするいうことでしょうか。
①が最初のコピーで、コピー元は常に8列～17列、コピー先は常に1列～10列になります。
②のときに、コピー元が29列空きます。コピー先が１列空きます。
③は最後のコピーです。

コピー元　　　　　　　コピー先
①
（30行, 8列～17列）→（3行,1列～10列）
（31行, 8列～17列）→（4行,1列～10列）
・・途中省略・・・
（1499行, 8列～17列）→（1472行,1列～10列）

②
（30行, 38列～47列）→（3行,12列～21列）
（31行, 38列～47列）→（4行,12列～21列）
・・途中省略・・・
（1499行, 38列～47列）→（1472行,12列～21列）

・・・
・・・
③
（30行, 758列～767列）→（3行,276列～285列）
（31行, 758列～767列）→（4行,276列～285列）
・・途中省略・・・
（1499行, 758列～767列）→（1472行,276列～285列）

tatsu99 · Answer

>並べるようにしたいのですが、わかりますでしょうか？
画像が小さすぎてわかりません。
上の画像と下の画像を2回に分けて提示していただけませんでしょうか。

tatsu99 · Answer

No4です。
コピー元からコピー先への転送は１セル単位でのコピーです。
最初の１０個のセルを例にとると、添付図のように
コピー元の①～⑩がコピー先の①～⑩に転送されるようになっています。
他のセルはコピーされません。（添付図の黄色の部分はコピーされません。）

tatsu99 · Answer

そうすると、コピー元のセルは、
（30行, 8列）～（1500行,18列）
（30行,38列）～（1500行,48列）
（30行,67列）～（1500行,77列）
ではなく
（30行, 8列）～（1499行,17列）
（30行,38列）～（1499行,47列）
（30行,68列）～（1499行,77列）
ですね。

同様に、コピー先のセルは
（3行,1列）～（1473行,10列）
（3行,12列）～（1473行,22列）
（3行,24列）～（1473行,34列）
でなく
（3行,1列）～（1472行,10列）
（3行,12列）～（1472行,21列）
（3行,23列）～（1472行,34列）
ですね。

又、コピー元最終列は777列ではなく767列ですね。
以下、その前提でのマクロです。
以下のようになります。
----------------------------------------------
Sub transfer()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row1 As Long
Dim row2 As Long
Dim i As Long
Dim j As Long
Dim col1 As Long
Dim col2 As Long
Set sh1 = Worksheets("Summary")
Set sh2 = Worksheets("SubSheet")
Application.ScreenUpdating = False
For i = 0 To 25
    For j = 0 To 1469
        row1 = j + 30
        col1 = i * 30 + 8 + (j Mod 10)
        row2 = j + 3
        col2 = i * 11 + 1 + (j Mod 10)
        sh2.Cells(row2, col2).Value = sh1.Cells(row1, col1).Value
    Next
Next
Application.ScreenUpdating = True
sh2.Select
Range("A1").Select
MsgBox ("完了")
End Sub
----------------------------------------------
尚、添付の図は、コピー元、コピー先のセル位置を表にまとめたものです。
黄色の部分が、こちらで訂正した箇所です。
この図のように、コピー元、コピー先のセル位置を解釈したマクロになっています。

tatsu99 · Answer

>コピー元のセル（30行, 8列）～（1500行,18列）
>コピー先のセル（3行,1列）～（1473行,10列）

この意味ですが、以下のように転送するということですか。

コピー元→コピー先
30行8列→3行1列
31行9列→4行2列
32行10列→5行3列
33行11列→6行4列
34行12列→7行5列
35行13列→8行6列
36行14列→9行7列
37行15列→10行8列
38行16列→11行9列
39行17列→12行10列
40行18列→13行1列・・・②
41行8列→14行2列・・・①
42行9列→15行3列
・・途中省略・・・
1500行18列→1473行10列

そうだとすると
コピー元のセルは18列の次は8列に戻るのですか。①のケース（41行8列）
コピー先のセルは10列の次は1列に戻るのですか。②のケース（13行1列）

tatsu99 · Answer

>しかし、29列目にあるデータを取得できません。
>なにかご存知でしょうか？
そもそも、どうなさりたいのでしょうか。
「SubSheetへ29列おきにジャンプして貼り付けて行きたい」ということだけでは、よくわかりません。
コピー元セルの位置（行、列）とコピー先セルの位置（行、列）を明確に提示していただければアドバイスできます。
そうでないと、アドバイスのしようがありません。

tatsu99 · Answer

とりあえず、エラーをとるだけなら、
Sheets("SubSheet").Range(Sheets("SubSheet").Cells(R + 2, W), Sheets("SubSheet").Cells(R + 2, W + 10)).Value = Sheets("Summary").Range(Sheets("Summary").Cells(R + 2, C + 11), Sheets("Summary").Cells(R + 2, C + 21)).Value

のようにしてください。

他に問題点は、
For R = 1 To Cells(Rows.Count, 1).End(xlUp).Rowですが
Summaryの最終行まで実行させたいと思われます。
この場合、Summaryシートを表示した状態でマクロが実行されれば、問題ないですが、
他のシートを表示した状態でおこなうと、他のシートの最終行が採用されてしまします。
その為、For R = 1 To Cells(Rows.Count, 1).End(xlUp).Rowの前の行に
Sheets("Summary").Activate
をいれておいた方が良いでしょう。

次が一番の問題ですが、本当に３重ループする必要があるのでしょうか。
これでうまく行くなら特に問題ありません。
この箇所を修正しようと思いましたが、そもそも、どのようにsummaryからSubsheetへ転記したいのかがよくわかりませんので
これまでとします。

シートのデータを29列おきにジャンプして別のシートに貼り付けて行きたい。

前回のは破棄してください。

>仰るとおりです。

すみません、画像がよく見えないのですが、

>並べるようにしたいのですが、わかりますでしょうか？

No4です。

そうすると、コピー元のセルは、

>コピー元のセル（30行, 8列）～（1500行,18列）

>しかし、29列目にあるデータを取得できません。

とりあえず、エラーをとるだけなら、

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング