行を挿入するマクロ

質問

画像の右の表を左の表のように自動で整えたいです。
A、ｂ、ｃ…グループがあって、それぞれ連番があります。
１から１８行したら次のグループの連番を１から開始となるように、詰まっている部分に空白行を挿入したいです。グループごとの番号は画像のように11で終わるとは限らず、１～18のうちのいずれかの数です。

回答No.5

kkkkkm · ベストアンサー

あと、ふと思ったのですが、例の場合A、B、Cと別データの区切りが連続してますが、もしA、B、Cの区切りに18行に満たない空白行があった場合は、No.2では18行分確保しませんので、そのような可能性がある場合は以下のコードで試してみてください。

Sub Test3()
Dim i As Long, Nc As Long
Dim GCount As Long, FRow As Long, mRow As Long

FRow = 8
Nc = 1
mRow = FRow
GCount = 18

For i = FRow To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(mRow, "A").Value <> "" And _
Cells(mRow + 1, "A").Value <> "" And _
Nc < GCount Then
If Cells(mRow + 1, "A").Value = Cells(mRow, "A").Value Then
Nc = Nc + 1
mRow = mRow + 1
Else
Rows(mRow + 1 & ":" & mRow + GCount - Nc).Insert Shift:=xlDown
mRow = mRow + GCount - Nc + 1
Nc = 1
End If
Else
Nc = Nc + 1
mRow = mRow + 1
If Cells(mRow, "A").Value = "" And _
Cells(mRow + 1, "A").Value <> "" And _
Nc < GCount Then
Rows(mRow + 1 & ":" & mRow + GCount - Nc).Insert Shift:=xlDown
mRow = mRow + GCount - Nc + 1
Nc = 1
End If
End If
Next

End Sub

お礼

A列グループ名がC列番号と同じ長さでない場合（入力がない）のことですね。A列とＣ列のデータあるなしは、同じですが、万一発生した場合、ご提案のコードに修正いたします。どうもそこまで考えていただきありがとうございました。

回答No.4

kkkkkm

すみません。
End Subが抜けてましたね、コピーの時に範囲に入れてなかったみたいです。

Nc < 18 Then
は

GCountに18と行数を入れているので

Nc < GCount

に訂正しておいてください。

蛇足ですが別の列に書き出す場合は

Sub Test2()
Dim i As Long, Nc As Long
Dim GCount As Long, FRow As Long, mRow As Long

FRow = 8
Nc = 1
mRow = FRow
GCount = 18

For i = FRow To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A").Value <> "" Then
If Nc <= GCount Then
If Cells(i + 1, "A").Value = Cells(i, "A").Value Then
Cells(mRow, "F").Resize(1, 2).Value = Cells(i, "A").Resize(1, 2).Value
mRow = mRow + 1
Nc = Nc + 1
Else
Cells(mRow, "F").Resize(1, 2).Value = Cells(i, "A").Resize(1, 2).Value
If Nc < GCount Then
Cells(mRow + 1, "F").Resize(GCount - Nc, 2).Value = ""
End If
mRow = mRow + GCount - Nc + 1
Nc = 1
End If
End If
End If
Next

End Sub

お礼

Nc < GCount　に訂正しました。
エラーがでたのでthen付けていけました。
別バージョンも考案してくださり、ありがとうございました。

回答No.3

kkkkkm

No.2の訂正です。

If Cells(mRow, "A").Value <> "" And _
Cells(mRow + 1, "A").Value <> "" Then

を

If Cells(mRow, "A").Value <> "" And _
Cells(mRow + 1, "A").Value <> "" And _
Nc < 18 Then

に変更してください。

お礼

修正してやってみましたが、できました。
どうもありがとうございます！！

回答No.2

kkkkkm

現在の表に行を挿入したいだけでしたら以下で試してみてください。

Sub Test1()
Dim i As Long, Nc As Long
Dim GCount As Long, FRow As Long, mRow As Long

FRow = 8
Nc = 1
mRow = FRow
GCount = 18

For i = FRow To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(mRow, "A").Value <> "" And _
Cells(mRow + 1, "A").Value <> "" Then
If Cells(mRow + 1, "A").Value = Cells(mRow, "A").Value Then
Nc = Nc + 1
mRow = mRow + 1
Else
Rows(mRow + 1 & ":" & mRow + GCount - Nc).Insert Shift:=xlDown
mRow = mRow + GCount - Nc + 1
Nc = 1
End If
End If
Next

お礼

できました！（End Subつけて）
早々にありがとうございました！

回答No.1

FattyBear

単純に、やりたいこととは、グループ名が変わるたびに空白行を
自動で挿入したいということですね？
番号もグループの連番数も関係無く上記の処理するということですね？

補足

はい、要は、グループごとに番号の数が違うので、等間隔にしたく、それぞれ18行間隔とし、番号が18に満たない場合は空白行を入れる、としたいです。この作業を毎日する予定なので、自動化でやりたいです。よろしくお願いします。