エクセル2002のVBAで、一グループごとにセルを追加する方法

質問

エクセル2002で、
A列のみにデータが入力されており、
一グループごとに上から順に並んでいます。

一グループの最初のセルの文字だけ赤色、
それ以外の文字は黒色です。

基本的に一グループごとに5行です。
ですが、中には一グループで3行になったり、4行になったりまちまちです。

例えば上から順に、
1つ目のグループの1番目（文字：赤色）
1つ目のグループの2番目
1つ目のグループの3番目
2つ目のグループの1番目（文字：赤色）
2つ目のグループの2番目
2つ目のグループの3番目
2つ目のグループの4番目
2つ目のグループの5番目
3つ目のグループの1番目（文字：赤色）
3つ目のグループの2番目
3つ目のグループの3番目
3つ目のグループの4番目

このように一グループの行数が3行になったり5行になったりしています。

一グループの最後の行のすぐ下に、次のグループのデーターが表示され、
対象となっているグループが変わっても、空白セルが挿入されることはなくA列にびっしりと入力されています。

この場合、
一グループの行数を6行以上にして、
一グループの行数が6行に足りない場合は最後のセルの下に6行になるまで空白セルを追加する方法があれば教えてください。

なお、私なりに試行錯誤した結果、
セルＡ2からセルＡ3までのセルの文字が赤色の場合に、赤字のセルの上に空白セルを追加するマクロを下記の通り作成するところまでは出来ました。

参考になるかもしれませんのでご覧下さい。

どうぞ宜しくお願い致します。

記

Sub Macro1()

If Cells(3, 1).Font.ColorIndex = 3 Then
Cells(3, 1).Select
Selection.Insert Shift:=xlDown
End If

If Cells(2, 1).Font.ColorIndex = 3 Then
Cells(2, 1).Select
Selection.Insert Shift:=xlDown
End If

End Sub

以上

回答No.1

xdaix · ベストアンサー

1行目が赤文字で、空白のセルがきたら終わりで良ければ

Option Explicit

Sub Test()

Dim i As Long
Dim j As Integer

'1行目は必ず赤文字と仮定して2行目から
i = 2: j = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Font.ColorIndex = 3 Then
Do Until j >= 6
Cells(i, 1).Insert Shift:=xlDown
i = i + 1: j = j + 1
Loop
j = 0
End If
i = i + 1: j = j + 1
Loop

End Sub

お礼

御礼が申し訳ありません。うっかり投稿したことを忘れてしまっていました。

アドバイスどおりにできました。お蔭様で作業が大変はかどります。

本当にありがとうございました。