外出自粛中でも楽しく過ごす!QAまとめ>>

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

元のデータの例   マクロ実行後
列A   列B      列A   列B
A組           A組  
氏名1 111      氏名1 111 
氏名2 222      氏名2 222
B組           空白行挿入
氏名3 333      空白行挿入
氏名4 444      B組
氏名5 555      氏名3 333
氏名6 666      氏名4 444
氏名7 777      氏名5 555
C組 氏名6 666
             氏名7 777
             空白行挿入
             空白行挿入
             空白行挿入
             空白行挿入
             C組

 

このQ&Aに関連する最新のQ&A

A 回答 (5件)

#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
    • good
    • 0

質問者さんのご説明で、「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
    • good
    • 0

「組で終わる」のが組名だという決まり事にします。


丁寧に拾っていけば、そんなに大変なあれやこれやをする事もなさそうです。


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 ’5の倍数になるまでループ
   c.entirerow.insert shift:=xlshiftdown
  loop
  set c = c2
 loop
end sub
    • good
    • 0

シート名は環境に合わせて変更の必要があります。


ご参考まで。
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さんのコードを使わせてもらい、
ほぼ理想の動きにはなりました。
ただ、ちょうど5行づつの区切りになった場合
A組









B組





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

補足日時:2013/12/26 00:36
    • good
    • 0

こんばんは!


外しているかもしれませんが・・・

データは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
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング