マクロのループが次へ進みません！！

質問

Sub 不要な行を削除()

Dim fWord As String, fAdd, c, wb As Workbook
fWord = "ああ"　　'←"ああ"の行は複数あります

'下記3行はなくてもよいかも。以前、あったほうがうまく実行できましたので。
Workbooks("てすと.xls").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown

With Workbooks("てすと.xls").Worksheets(1).Range("A:A")
Set c = .Find(fWord, LookIn:=xlValues)
If Not c Is Nothing Then
fAdd = c.Address
Do

　　c.Offset(-1, 0).EntireRow.Delete　
　　c.Offset(-1, 0).EntireRow.Delete
　　c.Offset(0, 0).EntireRow.Delete

　　Set c = .FindNext(c)　　'←ここからエラーとなってしまいます
Loop While Not c Is Nothing And c.Address <> fAdd
End If
End With

End Sub
---
「実行時エラー’1004’
　Range クラスのFindNextプロパティを取得できません。」
とエラー表示されてしまいます。
---
複数ある「"ああ"の行」の最上の1行だけにのみ実行されるだけです。

間違い箇所をご教示下さいませ。
よろしくお願い致します。

回答No.3

zap35 · ベストアンサー

この処理は"ああ"が含まれる行の２行上から、その行までを削除する処理ですか？

まず最初に変だと思うのは
＞Dim fWord As String, fAdd, c, wb As Workbook
です。fAddはc.Addressを代入しているので「As String」であるべきですし、またcは.Find(fWord, LookIn:=xlValues)をSetしているので「As Range」のなるはずです。これで動きましたか？

次に
＞　　c.Offset(0, 0).EntireRow.Delete
でFindで見つけたc自体を削除しています。だから
＞　Set c = .FindNext(c)　
ではエラーになります。.FindNextメソッドに与えるcが不定値になっているからです。　

Sub Macro1()
Dim c As Range
　Do
　　Set c = Range("A:A").Find(what:="ああ", LookIn:=xlValues, lookat:=xlWhole)
　　If c Is Nothing Then Exit Do
　　c.Offset(-2, 0).Resize(3, 1).EntireRow.Delete
　Loop
End Sub

おそらく質問文の内容の処理では「fAdd」は必要ありません。以上でいけると思います。ただし"ああ"を含む行を削除する条件がもう少し複雑なら「fAdd」が必要かもしれませんが、そこまでは質問文からは読み取れませんでした。

お礼

早速のご回答、ご詳細、誠に有難うございました。

＞この処理は"ああ"が含まれる行の２行上から、その行までを削除する処理ですか？

おっしゃられる通りでございます。
下記の3行のみ削除されただけでした。

4
2
5　　　←削除
3　　　←削除
ああ　←削除
8
5
6
1
9
ああ
3
5
5
1
ああ

説明不足で申し訳ありませんでした。
Resize　ですよね、頭がまわりませんでした。
自分としては、非常に難しいコードですので、時間をかけて、解読したいと思います。
でも、全ては、解読できないと思っております。

補足

ご回答されたコードは、一部のコードだと思ったのですが、
全部に、実行できてしまいました。
こんなにも、短縮してしまっていいんですね！！
私には、点数判定ができないようです・・・
　皆様、最良回答です。

回答No.2

imogasi

コードをそのまま質問に書いて読者・回答者に解読させるのでなく、処理の内容ぐらい文章で説明を添えるべきだ。
それとこの質問は、マクロの記録で、編集ー検索の操作を取れば、ヒントが得られるはず。
見つかったときの、処理内容は理解できなかったので略し、MSGBOXだけにしている。
質問はSheet1と限定してもよかろう。自分で修正できる内容は質問から省いて、コードを短くしてほしい。長いコードはかなわない。
Sub test01()
Range("A1").Activate
fword = "a"
With Worksheets(1).Range("A:A")
Set c = .Find(fword, LookIn:=xlValues)
If c Is Nothing Then Exit Sub
c.Activate
MsgBox c.Address
fAdd = c.Address '最初見つかったセル番地
Do
Set c = .FindNext(after:=ActiveCell)
MsgBox c.Address
c.Activate
Loop While Not c Is Nothing And c.Address <> fAdd
'End If
End With
End Sub
ーー
要点（推奨点、普通は検索は下記でやると言うこと。FindとFindNextを組み合わせるやり方。その場合は下記だということ）違うやり方Find一本やりも考えられそうだが。
（１）c.Activateにして、その後FindNext(after:=ActiveCell）が使えるようにする。
（２）.FindNextは同じ文字列などを探すので
.FindNext(c)
はしない。
私は別質問の回答で、VBAで検索をやるのは難しいですよと注意喚起している。）.FindNextはクセが有るように思う。

お礼

早速のご回答、ご詳細、誠に有難うございました。
説明不足で、申し訳ありませんでした。

回答No.1

Wendy02

こんばんは。

見つけた行をそのつど、削除してまったら、c に確保したRangeオブジェクトを見失ってしまうので、エラーが発生します。なるべく、元のコード自体は維持したまま、修正してみました。

Sub 不要な行を削除R()
　　Dim fWord As String, fAdd As String, c As Range, wb As Workbook
　　Dim ur As Range

　　fWord = "ああ"

　　Workbooks("てすと.xls").Activate
　　Rows("1:1").Select
　　Selection.Insert Shift:=xlDown

　　With Workbooks("てすと.xls").Worksheets(1).Range("A:A")
　　　　Set c = .Find(fWord, LookIn:=xlValues)
　　　　If Not c Is Nothing Then
　　　　　　fAdd = c.Address
　　　　　　Do
　　　　　　　　If c.Row = 2 Then　'2行目で発見したら
　　　　　　　　　 Set ur = c.Offset(-1).Resize(2)
　　　　　　　　ElseIf ur Is Nothing Then
　　　　　　　　　 Set ur = c.Offset(-2).Resize(3)
　　　　　　　　Else
　　　　　　　　　 Set ur = Union(c.Offset(-2).Resize(3), ur)
　　　　　　　　End If
　　　　　　　　Set c = .FindNext(c)
　　　　　　Loop While Not c Is Nothing And c.Address <> fAdd
　　　　End If
　　　　If Not ur Is Nothing Then
　　　　　　ur.EntireRow.Delete
　　　　End If
　　End With
End Sub

お礼

早速のご回答、誠に有難うございます。
ひょっとして、当方の説明不足もあったかもと思いましたが、
不思議ですね、キッチリ動作しました。