excelのマクロで条件による行の挿入

質問

列AとBがあり列Aに学校のクラス名A組、B組、C組・・・（２０クラスほど）と氏名が
入るエクセルシートがあるのですが
先頭行はA組から始まり５行区切りで数え、（A組も5行のうちに入る）
その５行内に次のB組が入らないように空白行を挿入したいです
もし、5行以内にB組がない場合、次の５行でまたB組があるか判定しなければ氏名５つ
あれば空白をいれてというのを２０クラスぶん作るマクロは可能でしょうか？
VBAの知識がさっぱりないので途方にくれています。

元のデータの例　　　マクロ実行後
列A　　 列B　　　　　　列A　　 列B
A組　　　　　　　　　　　A組　　
氏名１　111　　　　　　氏名１　111　
氏名２　222　　　　　　氏名２　222
B組　　　　　　　　　　　空白行挿入
氏名3　333　　　　　　空白行挿入
氏名4　444　　　　　　B組
氏名５　555　　　　　　氏名3　333
氏名６ 666　　　　　　氏名4　444
氏名７　777　　　　　　氏名５　555
C組 氏名６ 666
　　　　　　　　　　　　　氏名７　777
　　　　　　　　　　　　　空白行挿入
　　　　　　　　　　　　　空白行挿入
　　　　　　　　　　　　　空白行挿入
　　　　　　　　　　　　　空白行挿入
　　　　　　　　　　　　　C組

回答No.5

mitarashi · ベストアンサー

#2です。
検証が甘くて申し訳ありません。下記でお試し願います。
Sub test()
Dim mycell As Range
Dim i As Long

Application.ScreenUpdating = False
Set mycell = Sheets("Sheet1").Range("A1")
i = 1
Do Until mycell.Offset(i, 0).Value = ""
If mycell.Offset(i, 0).Value Like "*組" Then
Set mycell = mycell.Offset(i, 0)
Application.CutCopyMode = False
'5の倍数なら何もしない様にした
If (i Mod 5) <> 0 Then
mycell.Resize(((i \ 5) + 1) * 5 - i, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
i = 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
End Sub

回答No.4

MarcoRossiItaly

質問者さんのご説明で、「5 行区切り」というものの中に、空白行が入っているのかいないのか、の判断がつきませんでした。

「氏名 5 つ」との表現もみられるので、空白を含めれば、6 行ってことかしら？でも質問文の「マクロ実行後」を見ると、「A組」の 5 行下に「B組」が来ているから、6 行になっていないですよね…？

下のコードでは、とりあえず空白を含めて 6 行だと見ています。

使っている数式は若干異なっていますが、2 列を挿入・削除しているという点で、No.1 さんのコードと同じようなものです。

Sub SixRows()
　　Dim lr As Long, i As Long
　　Columns("a:b").Insert
　　Rows(1).Insert
　　lr = Cells(Rows.Count, "c").End(xlUp).Row
　　Range(Range("b2"), Cells(lr, "b")).Formula = "=1+b1*countif(c2,""<>*組"")"
　　Range(Range("a2"), Cells(lr, "a")).Formula = "=b2-1"
　　For i = lr To 3 Step -1
　　　　If Cells(i, "a") Mod 5 = 0 Then Rows(i & ":" & i + 4 - Cells(i - 1, "a").Value Mod 5).Insert
　　Next i
　　Columns("a:b").Delete
　　Rows(1).Delete
End Sub

回答No.3

keithin

「組で終わる」のが組名だという決まり事にします。
丁寧に拾っていけば、そんなに大変なあれやこれやをする事もなさそうです。

sub macro1()
　dim c as range
　dim c2 as range

’初期化
　if application.countif(range("A:A"), "*組")<2 then exit sub
　set c = range("A:A").find(what:="*組",lookin:=xlvalues, lookat:=xlwhole, searchdirection:=xlprevious)

　do　’組ごとループ（下から）
　　set c2 = range("A:A").findprevious(c)
　　if c2.row > c.row then exit do

　　do until (c.row - c2.row) mod 5 = 0　’５の倍数になるまでループ
　　　c.entirerow.insert shift:=xlshiftdown
　　loop
　　set c = c2
　loop
end sub

回答No.2

mitarashi

シート名は環境に合わせて変更の必要があります。
ご参考まで。
Sub test()
Dim mycell As Range
Dim i As Long

Application.ScreenUpdating = False
Set mycell = Sheets("Sheet1").Range("A1")
i = 1
Do Until mycell.Offset(i, 0).Value = ""
If mycell.Offset(i, 0).Value Like "*組" Then
Set mycell = mycell.Offset(i, 0)
Application.CutCopyMode = False
mycell.Resize(((i \ 5) + 1) * 5 - i, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
End Sub

補足

mitarashiさんのコードを使わせてもらい、
ほぼ理想の動きにはなりました。
ただ、ちょうど５行づつの区切りになった場合
A組
あ
あ
あ
あ

B組
い
い
い

と何もない行が５行続いてしまうのが難点です。
VBAの勉強はじめてはみたのですがまだ私には
直せるような技術はないのでまだこちらを見ていたらご教授願います。

回答No.1

tom04

こんばんは！
外しているかもしれませんが・・・

データはA1セルからあり、クラスには必ず「○組」と「組」の文字が入っているという前提です。

Sub 行挿入()
Dim i As Long, k As Long, insRow As Long, endRow As Long
endRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Range("A:B").Insert
Range("B1") = Range("C1")
With Range(Cells(2, "B"), Cells(endRow, "B"))
.Formula = "=IF(COUNTIF(C2,""*組""),C2,B1)"
.Value = .Value
End With
With Range(Cells(1, "A"), Cells(endRow, "A"))
.Formula = "=COUNTIF(B$1:B1,B1)"
.Value = .Value
End With
For i = endRow + 1 To 2 Step -1
If Cells(i, "B") <> Cells(i - 1, "B") Then
insRow = 5 - (Cells(i - 1, "A") Mod 5)
Rows(i & ":" & i + insRow - 1).Insert
ElseIf Cells(i, "A") Mod 5 = 0 Then
Rows(i + 1).Insert
End If
Next i
Range("A:B").Delete
Application.ScreenUpdating = True
End Sub

こんな感じでよいのでしょうかね？m(_ _)m