【VBA】セルとシート操作の繰り返し処理

質問

添付画像のような、5行10列からなる１つの表を、2行間隔で作成しています。
VBAを使って、下記のような繰り返し処理をしたいと思っております。

処理１：シート(１)の表に、1行間隔でセルの塗りつぶし色を付ける。
処理２：このシート(１)をコピーして、test(１)～(６)までの６シートを作成する。
　　　　※コピーしたシート名を「test(１)～(６)」に変更する
処理３：コピーしたtest(２)の「B2」「B11」「B20」「B29」「B38」値を「6」～「10」にナンバリングし、
　　　　同様にtest(３)～test(６)のB列の番号も「11」～「30」に変更する

VBAを使って、添付画像のようなのような処理１～３の繰り返し行うことは可能でしょうか？
うまく説明できず申し訳ございませんが、画像を参考にしていただければと思います。

もし可能であれば、その方法を教えてください。
お手数お掛けいたしますが、よろしくお願い致します。

回答No.1

MarcoRossiItaly · ベストアンサー

＞もし可能であれば、その方法を教えてください。

基本的に Excel において、手作業でできることは何でも、VBA でもできるとお考えください。

「『6』」～『10』にナンバリング」とは、「 6 ～ 10（の丸数字）を記入」という意味ですか？しかし 21 以上の丸数字は環境依存文字となるため、とりあえず test(1) ～ test(6) まで全て、B 列には、単なる数値を記入するようにしました。

ColorIndex の具体的な値については、参考 URL などを参照してください。

Sub MakeTestSheets()
　　Dim i As Long, j As Long
　　With Worksheets("シート(1)")　　'←全角／半角に注意して正しいシート名に修正
　　　　For i = 4 To 40 Step 9
　　　　　　Intersect(Union(.Rows(i), .Rows(i + 2)), .Range("b:m")).Interior.ColorIndex = 3
　　　　Next i
　　　　Application.Goto reference:=.Range("a1"), scroll:=True
　　　　For i = 1 To 6
　　　　　　.Copy after:=Worksheets(.Index + i - 1)
　　　　　　With ActiveSheet
　　　　　　　　.Name = "test(" & i & ")"
　　　　　　　　For j = 1 To 5
　　　　　　　　　　.Cells(9 * j - 7, "b").Value = 5 * (i - 1) + j
　　　　　　　　Next j
　　　　　　End With
　　　　Next i
　　End With
End Sub

参考URL：

http://www.relief.jp/itnote/xls_colorindex.php

お礼

早々にご回答くださり誠にありがとうございます。
ご教示いただいたVBAで動作確認しましたら、希望通りの結果を得ることができました！
本当にありがとうございました(#^.^#)

回答No.4

tom04

No.2・3です。
何度もごめんなさい。

処理3を勘違いしていました。
「test1」のSheetは1～5　「test2」が6～10　というナンバリングですね。

前回のコード内の
＞ cnt = 5
の1行を削除してください。m(_ _)m

お礼

早々にご回答くださり誠にありがとうございます。
ご教示いただいたVBAで動作確認しましたら、希望通りの結果を得ることができました！
本当にありがとうございました(#^.^#)

回答No.3

tom04

No.2です。
たびたびごめんなさい。

前回は1つの表が1行少なくみていました。
↓のコードに変更してください。

Sub Sample2()
Dim i As Long, k As Long, cnt As Long
With Worksheets(1)
.Range("B4").Resize(, 12).Interior.ColorIndex = 38 '←ローズ
.Range("B6").Resize(, 12).Interior.ColorIndex = 38
.Range("B4:M6").Copy
For i = 13 To 40 Step 9
Cells(i, "B").PasteSpecial Paste:=xlPasteFormats
Next i
.Range("A1:M44").Copy
End With
If Worksheets.Count < 7 Then
Do Until Worksheets.Count = 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
Loop
End If
cnt = 5
For k = 2 To 7
With Worksheets(k)
.Range("A1").PasteSpecial Paste:=xlPasteAll
For i = 2 To 38 Step 9
cnt = cnt + 1
.Cells(i, "B") = cnt
Next i
.Name = "test(" & k - 1 & ")"
End With
Next k
Worksheets(1).Activate
ActiveSheet.Range("A1").Select
End Sub

どうも失礼しました。m(_ _)m

回答No.2

tom04

こんにちは！
一例です。
塗りつぶしの色が濃い場合、データが見えにくいので「ローズ」にしています。

アップされている画像通りの配置だとして・・・
標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, cnt As Long
With Worksheets(1)
.Range("B4").Resize(, 12).Interior.ColorIndex = 38 '←ローズ
.Range("B6").Resize(, 12).Interior.ColorIndex = 38
.Range("B4:M6").Copy
For i = 12 To 38 Step 8
Cells(i, "B").PasteSpecial Paste:=xlPasteFormats
Next i
.Range("A1:M39").Copy
End With
If Worksheets.Count < 7 Then
Do Until Worksheets.Count = 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
Loop
End If
cnt = 5
For k = 2 To 7
With Worksheets(k)
.Range("A1").PasteSpecial Paste:=xlPasteAll
For i = 2 To 34 Step 8
cnt = cnt + 1
.Cells(i, "B") = cnt
Next i
.Name = "test(" & k - 1 & ")"
End With
Next k
Worksheets(1).Activate
ActiveSheet.Range("A1").Select
End Sub

こんな感じではどうでしょうか？m(_ _)m