エクセルVBAにて、特定文字の前に行を追加したい

質問

こんにちは。

エクセルVBAにて、特定文字が含まれる行の前に空白の行を挿入するマクロはどのように書けばいいでしょうか。
そして、特定文字が連続して入力されている場合、連続した文字の個数と同じ行数を、連続した最初の文字の前に挿入したいと思っています。

特定文字＝ラーメン

1行目 うどん
2行目 ラーメン（この上に3行挿入）
3行目 ラーメン
4行目 ラーメン
5行目 うどん
6行目 うどん
7行目 ラーメン（この上に1行挿入）
8行目 うどん
9行目 ラーメン（この上に2行挿入）
10行目 ラーメン
11行目 うどん

下記のようなコードを検索結果を参考に作成しましたが、これだとラーメンの上にすぐ空白の行が挿入されてしまい、連続した最初の特定文字の上にまとめて挿入する事ができません。

Sub Test()
Dim a As Range
Dim j As Long, k As Long

j = WorksheetFunction.CountIf(Columns(3), "ラーメン")

Set a = Range("C1")
Do
Set a = Columns(3).Find(What:="ラーメン" _
, After:=a _
, LookIn:=xlValues _
, LookAt:=xlWhole _
, SearchDirection:=xlPrevious)
If Not a Is Nothing Then
k = k + 1
a.EntireRow.Insert
End If
Loop While k < j
End Sub

どうすればいいかご教授お願いいたします。

回答No.7

real beatin（@realbeatin）

回答No.1です。

なんか盛り上がってますね。色んな意味で。

この課題、やり方は無数にあるということはご覧の通りな訳ですが、
混乱を避ける意味で、一応、
どんな意図で解答をしているのか、という説明
をこちらから加えながら、その他の簡単な方法も紹介してみます。

回答No.1では、ご質問で例示された、
range.Find メソッド の扱い方に重点をおいたものを紹介しています。
range.Find メソッド は良く使う基本技ですので、
扱い方をキチンと理解しておいた方が好い、という意図で書いています。
VBAのヘルプで range.Find メソッド を読んでみると解ると思いますが、
> 同じ検索を繰り返すときは、FindNext メソッドおよび FindPrevious メソッドを使用します。
推奨された方法、を、まず理解しておいた方が宜しいかと。
非VBAの場合で考えると、
●Ctrl+F で[検索と置換]ダイアログを表示して、
　　[次を検索]ボタンを最初に押した時にあたるのが
　　　range.Find メソッド
　　続けて[次を検索]ボタンを２回目以降に押した時は
　　　range.FindNext メソッド
●Ctrl+F で[検索と置換]ダイアログを表示して、
　　Shiftキー＋[次を検索]ボタンを最初に押した時にあたるのが
　　　range.Find メソッドの SearchDirection:=xlPrevious 指定
　　続けてShiftキー＋[次を検索]ボタンを２回目以降に押した時は
　　　range.FindPrevious メソッド
ということになります。
range.FindNext メソッド、range.FindPrevious メソッド、には、
終着点がないので、下手な書き方をすると無限ループを招く、
といった恐怖心？がもとで、食わず嫌いの方が結構多いようなのですが、
２～３通りも形で覚えておけば、困ることはまずないです。

、、、以下、range.Find メソッドを離れて、、、。

回答No.1でも触れた、AutoFilterを使った例を紹介します。
意図としては、項目タイトル行がある、という前提ひとつで、Excelは
ただの<表>をひとつの<テーブル>として看做しますから、
用意された多彩な機能の中から、選ぶ機会が増える、
という例を示すことにあります。
既述の通り、状況が許すなら、ですが、
項目タイトル行は有った方が、
多くの場合、処理を簡素化する選択肢が増えることにはなります。

例では、ご提示のサンプルについて、
一旦、項目タイトル行を挿入して、
[フィルター]機能を使って一括で行挿入をして、
後に、項目タイトル行を削除しています。
★でマークした行は、本来不要な記述です。

Sub ReW9197009c()
　　Rows(1).Insert　'　★　最初から項目タイトル行があるなら、この行の処理不要
　　Range("A1:C1").Value = Split("a b c")　'　★　〃
　　Cells.AutoFilter Field:=3, Criteria1:="ラーメン", Operator:=xlOr
　　Range("2:" & Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.Select
　　Cells.AutoFilter
　　Selection.Insert
　　Rows(1).Delete　'　★　〃
End Sub

最後に、作業セルを活用する例を挙げます。
Excelの数式などでもそうですが、一息に処理を纏めるよりも、
段階的に分けて処理する方が、無駄なく簡潔に纏められる場合が結構多いです。
予め作業用の列を固定的に用意しておくこと等出来れば尚更、
これもExcelに用意された一般機能を活用し易くする例として
紹介するものです。
また、簡素に短時間で書ける、というのは、それはそれで価値のあるものです。

例では、１列めに（作業用の）列を挿入しておいて、そこに
Excel数式による判定（挿入したい行は数値、それ以外はエラー）を書いておいて、
[ジャンプ]機能（range.SpecialCells）で篩に掛けて、一括で行挿入をして、
後に、作業列を削除しています。

Sub ReW9197009a()
　　Columns(1).Insert　'　★　最初から作業列を特定出来るなら、この行の処理不要
　　With Range("A1:A" & Cells(Rows.Count, "D").End(xlUp).Row)　'　▼　★の場合、"D" は "C"
　　　　.FormulaLocal = "=1/(D1=""ラーメン"")"　'　▼　★の場合、D1 は C1
　　　　.SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow.Insert
　　End With
　　Columns(1).Delete　'　★　〃
End Sub

以上、なにか疑問が残るようでしたら、補足欄ででも、おたずねください。

追伸、
"ご教授..." って、Web上でも超メジャーな誤用ですけれど、
正しくは "ご教示..." です。
印象悪く受け止める方も少なくないようなので、一応、情報として。

回答No.6

imogasi

#3です。さらに考え直して、下記の方がわかりやすい（また他シートを使わないのでよい）と思ったので上げます。
同じロジックで回答がすでに出ているかもしれない。その場合は後免。
ーー
「行挿入問題には最下の行から上方向に処理」という、一応のセオリーがありそれに従って、
（下記の例データのb は「ラーメン」のつもり）
Sub test01()
連続 = 0
lr = Range("A10000").End(xlUp).Row
For i = lr To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") And Cells(i, "A") = "b" Then
連続 = 連続 + 1
Else
If 連続 <> 0 Then
Cells(i, "A").Resize(連続 + 1).EntireRow.Insert
連続 = 0
End If
End If
Next i
End Sub
例データ
a
b
b
b
v
c
c
f
g
b
b
b
j
j
j
h
b
b

処理結果
a

b
b
b
v
c
c
f
g

b
b
b
j
j
j
h

b
b

回答No.5

ushi2015

こんにちは、No4です
良くみたら元データC列でしたね。
他の列のデータも関連するかもしれないので、同じSheet1で処理するとして、
Sub test1()
　　Dim sh1 As Worksheet
　　Dim i As Long
　　Dim a As Long
　　Dim r As Range

　　Set sh1 = Worksheets("Sheet1")

　　With sh1.UsedRange
　　　　With .Offset(, .Columns.Count)
　　　　　　.Formula = "=IFERROR(FIND(""ラーメン"",$C1,1),"""")"
　　　　　　.Value = .Value
　　　　　　On Error GoTo err_Line
　　　　　　Set r = .SpecialCells(xlCellTypeConstants)
　　　　　　a = r.Areas.Count
　　　　　　For i = a To 1 Step -1
　　　　　　　　r.Areas(i).EntireRow.Insert xlShiftDown
　　　　　　Next
　　　　　　.ClearContents
　　　　End With
　　End With
　　Exit Sub

err_Line:
　　MsgBox Err.Description
End Sub
ファイルのバックアップしておいてから試して下さい。

回答No.4

ushi2015

こんにちは
Sheet2にデータをコピーして処理しています。
Sub test()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim i As Long
　　Dim a As Long
　　Dim r As Range

　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")

　　sh2.UsedRange.ClearContents
　　sh1.Range("A1").CurrentRegion.Copy sh2.Range("A1")

　　With sh2.Range("A1").CurrentRegion
　　　　With .Offset(, .Columns.Count)
　　　　　　.Formula = "=IFERROR(FIND(""ラーメン"",$A1,1),"""")"
　　　　　　.Value = .Value
　　　　　　On Error GoTo err_Line
　　　　　　Set r = .SpecialCells(xlCellTypeConstants)
　　　　　　a = r.Areas.Count
　　　　　　For i = a To 1 Step -1
　　　　　　　　r.Areas(i).EntireRow.Insert xlShiftDown
　　　　　　Next
　　　　　　.ClearContents
　　　　End With
　　End With
　　Exit Sub
err_Line:
　　MsgBox Err.Description
End Sub

回答No.3

imogasi

VBAコードなど書いて質問する前に、処理ロジックを「文章に」（またはフローチャートにして）書いてみて、じっくり考えるべきことだ。
初心者は、文章に書いてみて、じっくり考えて、漏れるケースや異例のケースがないか考える癖を付けることだ大切。そのプロセスをどれだけやったのか、すっ飛ばしてないか。
ーー
ポイント
Sheet1に行挿入をすると、現在の処理行が動くので、別シート（Sheet2)に、望むものを作る方式をお勧め。
ーー
A。横１行に「ラーメン」がないか検索する。
１つのセルにでもあれば「あり」と判定し、その行の検索は打ち切り
　・見つからない行の場合　　それまでの「後仕舞」
　　　後仕舞　　見つかった件数分データだけ別シートにコピー。（スペース行は見つかっ　　　　　　　　た都度に挿入済み）
　　　　　　　　見つかった件数を０にリセット
　　　　　　　　見つかった最初の行番号記憶変数を空白にする
　　　現在行データ　　現在行を別シートにコピーする
　　　　　　　　別シートでの貼り付け位置をしっかりとらえておく
　・見つかった行の場合　別シートSheet2（次行）に空白行１行挿入　
　　　　　　　　見つかった最初の行番号記憶変数が空白なら、今の行番号をセット
　　　　　　　　空白でなければそのままにする
　　　　　　　　見つかった最初の行番号を記憶
　　　　　　　(見つかった最初の行と今回の「連」で見つかった行数をカウント保持する）
　　　　　　　見つかった件数に＋１
　　　　　　　次行処理へ
＝＝＝＝＝
A列だけ「ラーメン」があるかないかの例に簡略化した。
標準モジュールに
Sub test01()
'初期化
pos = 0
kensu = 0
k = 1 'Sheet2の行ポインター
'--Sheet1各行処理
For i = 1 To 11
If Cells(i, "A") = "ラーメン" Then
Worksheets("sheet2").Cells(k, "A") = "" '空白行の挿入
k = k + 1
If pos = 0 Then
pos = i
End If
kensu = kensu + 1
Else
'---
If kensu = 0 Then
Worksheets("sheet2").Cells(k, "A") = Worksheets("Sheet1").Cells(i, "A")
k = k + 1
Else
'--保留した行をコピー貼り付け
For m = pos To pos + kensu
Worksheets("sheet2").Cells(k, "A") = Worksheets("Sheet1").Cells(m, "A")
k = k + 1
Next m
pos = 0
kensu = 0
End If
'--ラーメンなしの現在行をコピー
Worksheets("Sheet2").Cells(k, "A") = Worksheets("Sheet1").Cells(i, "A")
End If
Next i
End Sub
＝＝＝＝
例データ
Sheet1　A列
うどん
ラーメン
ラーメン
ラーメン
うどん
うどん
ラーメン
うどん
ラーメン
ラーメン
うどん
＝＝＝＝＝
結果
Sheet2　A列
うどん

ラーメン
ラーメン
ラーメン
うどん
うどん

ラーメン
うどん

ラーメン
ラーメン
うどん
うどん
ーー
ややロジックが複雑で、もっと良い（すっきりした)回答が出れば勉強します。
しかし、こういう類似パターンは経験があるので、出ない予想だが。

回答No.2

kkkkkm

もとのコードのイメージを残して変更してみましたがいかがでしょう。

Sub Test()
Dim a As Range
Dim MyRow As Long, k As Long, i As Long, AddRowsCount As Long

MyRow = Cells(Rows.Count, 3).End(xlUp).Row
Do
Set a = Range(Cells(1, 3), Cells(MyRow, 3)).Find(What:="ラーメン" _
, LookIn:=xlValues _
, LookAt:=xlWhole _
, SearchDirection:=xlPrevious)
AddRowsCount = 0
If a.Row > 1 Then
For i = 1 To a.Row
If a.Offset(-i, 0).Value = "ラーメン" Then
AddRowsCount = AddRowsCount + 1
Else
Exit For
End If
Next i
End If
If Not a Is Nothing Then
Range(a, a.Offset(-AddRowsCount, 0)).EntireRow.Insert
MyRow = a.Offset(-AddRowsCount, 0).Row - 1
End If
Loop While MyRow > 1
End Sub

回答No.1

real beatin（@realbeatin）

こんにちは。

とりあえず、こんな感じ。

Sub ReW9197009()
Dim c As Range
Dim nRowB As Long, nRowT As Long
　　With Columns("C")
　　　　Set c = .Find( _
　　　　　　What:="ラーメン", _
　　　　　　LookIn:=xlValues, _
　　　　　　LookAt:=xlWhole, _
　　　　　　SearchDirection:=xlPrevious)
　　　　If c Is Nothing Then Exit Sub
　　　　nRowT = c.Row
　　　　nRowB = nRowT
　　　　Do
　　　　　　Set c = .FindPrevious(c)
　　　　　　If c.Row <> nRowT - 1 Then
　　　　　　　　Rows(nRowT & ":" & nRowB).Insert
　　　　　　　　If c.Row > nRowB Then Exit Do
　　　　　　　　nRowB = c.Row
　　　　　　End If
　　　　　　nRowT = c.Row
　　　　Loop
　　End With
　　Set c = Nothing
End Sub

もしも、１行めに項目行があるなら、
AutoFilterで抽出して、より簡単にできますね。
状況が許すなら、検討してみて下さい。