VBA 繰り返し処理について教えてください

質問

VBA初心者です。
　　　A　　　　B　　　　　　　C　　　　D
1　
2　　項目　品名　　　　　　　数量　　　単位
3　　　　　内訳（別紙明細）　1　　　　 式
4　　　　　ブレーカ　　　　　　1　　　　 ヶ
5　　　　　消耗品　　　　　　　1　　　　 式　　
6　　　　　　　　　　　　
7
8　　　　　　　　　　　小計
上記（見積書）のような表があり、『小計』の文字を検索して
行を挿入したり、斜め線を引くという内容をVBAでやりたいと思います。
以下が記述です。
*************************************************************
Sub 斜め線描画()

Dim MyLine As Shape
Dim rngStart As Range, rngEnd As Range
Dim BX As Double, BY As Double, EX As Double, EY As Double

Set c = Cells.Find(What:="小計", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address

Set rngStart = c.Offset(1, -1)
Set rngEnd = c.Offset(-2, 0)

BX = rngStart.Left
BY = rngStart.Top
EX = rngEnd.Left + rngEnd.Width
EY = rngEnd.Top

c.Offset(-2, 0).Select
Selection.EntireRow.Insert
ActiveCell.EntireRow.Select
Selection.RowHeight = 2
c.Offset(1, 0).Select
Selection.EntireRow.Insert
ActiveCell.EntireRow.Select
Selection.RowHeight = 2

Set MyLine = Sheet4.Shapes.AddLine(BX, BY, EX, EY)
BX = BX + 151.5
BY = BY - 27
EX = EX - 152.25
EY = EY + 26.25
Set MyLine = Sheet4.Shapes.AddLine(BX, BY, EX, EY)

End If
End Sub
****************************************************************
『小計』の個数は決まっておらず、1個の場合もあれば10個の場合もあります。
『小計』があるだけ上記の処理を繰り返すようにしたいのですが、繰り返しの処理がうまくいかず、無限ループにはまってしまい困っています。
自分なりに考えたのは『小計』の文字はB列にあるので、B列に入力されている最後のセルまで検索したら処理を終了する。なのですが、どう記述していいのかわかりません。

文章がわかりにくいかもしれませんが、どうかご教授願います！

回答No.2

Wendy02 · ベストアンサー

こんばんは。

それは、行の挿入を加えているので、1順してくると、最初に見つけた場所と違ってしまいますから、たとえFindNext を使用しても、無限ループになってしまいます。ですから、今の方法ですと、「小計」という文字の数を数えて処理するしかないと思います。それと、こういう場合は、サブルーチンにしたほうが、読みやすくなります。

ただし、WorksheetFunction.CountIf(Cells, "*小計*")　は、本来は、列が決まっているなら、たとえば、Cells の代わりに、Columns(3) などのほうがよいと思います。なお、位置関係などの係数は、こちらでは分かりませんので、そのまま移しました。

Sub 斜め線描画R()
　　Dim MyLine As Shape
　　Dim c As Range
　　Dim cnt As Integer
　　Dim i As Integer

　　cnt = WorksheetFunction.CountIf(Cells, "*小計*")

　　Set c = Cells.Find(What:="小計", _
　　　　　　　　　　　 LookIn:=xlFormulas, _
　　　　　　　　　　　 LookAt:=xlPart)
　　If Not c Is Nothing Then
　　　　i = 1
　　　　Call LineArranging(c)
　　　　Do
　　　　If i >= cnt Then Exit Sub 'カウントでチェック
　　　　　Set c = Cells.FindNext(c)
　　　　　If c Is Nothing Then Exit Sub
　　　　　　 Call LineArranging(c)
　　　　　i = i + 1
　　　　Loop
　　End If
　　Set c = Nothing
End Sub
Sub LineArranging(rng As Range)
　Dim BX As Double, BY As Double, EX As Double, EY As Double
　Dim rngStart As Range, rngEnd As Range
　Dim myLine As Shape

　　　　Set rngStart = rng.Offset(1, -1)
　　　　Set rngEnd = rng.Offset(-2, 0)

　　　　BX = rngStart.Left
　　　　BY = rngStart.Top
　　　　EX = rngEnd.Left + rngEnd.Width
　　　　EY = rngEnd.Top

　　　　With rng.Offset(-2, 0)
　　　　　 .EntireRow.Insert
　　　　　 .RowHeight = 2
　　　　End With
　　　　With rng.Offset(1, 0)
　　　　　　.EntireRow.Insert
　　　　　　.RowHeight = 2
　　　　End With
　　　　Set MyLine = Sheet4.Shapes.AddLine(BX, BY, EX, EY)
　　　　　　BX = BX + 151.5
　　　　　　BY = BY - 27
　　　　　　EX = EX - 152.25
　　　　　　EY = EY + 26.25
　　　　Set MyLine = Sheet4.Shapes.AddLine(BX, BY, EX, EY)

　　　　Set rngStart = Nothing
　　　　Set rngEnd = Nothing
　　　　Set MyLine = Nothing　　　　
End Sub

お礼

回答ありがとうございます。
無限ループに入った理由がわかりました！
行挿入のためだったのですね。勉強になりました！！
早速試してみたら、期待通りの結果が得られました。
本当にありがとうございました（*^_^*）

またお聞きすることがあるかもしれませんが、よろしくお願い致します。

回答No.1

SAKENOSAKA

firstAddress を　代入していますよね。
検索対象がそのアドレスと同じだったら
もう終わりという処理にしたらいけると思います。
次々検索するためにはFindNextという命令があるので
調べてみてください。

お礼

回答ありがとうございます。
実は教えていただいた方法はすでに試したのですが、無限ループに入ってしまい困ってしまったのです。