VBAで任意の文字のその上の行を全て行削除したい

質問

エクセルのVBAで困っています よろしくお願いします。
VBAで任意の文字を探し その上の行を全て行削除したいのです
その文字は必ず２～３０行の中にあります。列はJからですが、行はランダムで毎回違います。
作業の途中までのマクロは記録コマンドで作成し、ボタンも作成してあります。
これができれば後はまた記録したマクロにて作業ができます。
アドバイス　よろしくお願いします！

回答No.1

merlionXX · ベストアンサー

部分一致検索の一例です。
２～３０行の中から検索し、あればその上の行をすべて行削除します。

Sub test1()
Set tg = Rows("2:30").Find(What:="任意の文字列", LookAt:=xlPart)
If tg Is Nothing Then
MsgBox "見当たりません"
Else
Rows("1:" & tg.Row - 1).Delete
End If
End Sub

お礼

ありがとうございました！
おかげさまで作業が進みました。
ほんとに感謝です！

回答No.2

imogasi

FindtoFindNextでその文字列のあるセルを見つけたなら、セル（番地）が判るわけです。
本当は範囲の下（の行）から探せれば、以下の苦労が無いのだが。
見つかったセルの上行は、行番号ー１で判る。しかし上行を削除すると行が１行繰り上がる。それで同行で、第2番目に、探している文字列があれば、余分に行を削除してしまう。
（１）文字列は範囲で１つしか見当たらないものか
（２）同行で２つ以上のセルで見つかるのか
（３）１つのセルの中でも２つ見つかる場合があるのか。
いずれもある行で見つかったら、次の探索は次行A列から行うようにする。ただ削除で繰り上がってきていることを忘れないで。
ーー
安全な方法は臨時の列に、その行にその文字列ありのフラグを立て、全行に渉ってフラグを立てる。終わって最下の行から、フラグのたっている行を削除など考えられる。
ーーー
前段階
下記で文字列を含むセルを全て番地で捉えた。文字列を含むかどうかでLookAt:=xlPartをWholeに変える。
Sub test01()
With Worksheets("Sheet1").UsedRange '---DataBaseの1列目が対象
Set c = .Find(What:="aa", LookIn:=xlValues, _
LookAt:=xlPart) '---cに検索結果を格納
If Not c Is Nothing Then '---条件に当てはまるセルがあれば
firstAddress = c.Address '---最初のセルのアドレスを覚える
MsgBox c.Address
Do '---do...Loopステートメント
Set c = .FindNext(c) '---今見つけたセルから次のセルを検索
If Not c Is Nothing And c.Address <> firstAddress Then
MsgBox c.Address
Else
Exit Do
End If
Loop '----条件に当てはまる全てを検索
End If
End With
End Sub
＝＝＝＝
ここで　Msgboxの行で処理に入る。
Sub test01()
Dim c As Range
With Worksheets("Sheet1").Range("a1:F14") '---このセル範囲が対象
Set c = .Find(What:="aa", LookIn:=xlValues, _
LookAt:=xlPart) '---cに検索結果を格納
If Not c Is Nothing Then '---条件に当てはまるセルがあれば
firstAddress = c.Address '---最初のセルのアドレスを覚える
B = Worksheets("Sheet1").Range("A" & c.Row).Address
c.EntireRow.Delete
Worksheets("Sheet1").Range(B).Activate
Do '---do...Loopステートメント
On Error GoTo err1
Set c = .FindNext(ActiveCell) '---今見つけたセルから次のセルを検索
If Not c Is Nothing And c.Address <> firstAddress Then
B = Worksheets("Sheet1").Range("A" & c.Row).Address
c.EntireRow.Delete
MsgBox Worksheets("Sheet1").Range(B).Address
Worksheets("Sheet1").Range(B).Activate
Else
Exit Do
End If
Loop '----条件に当てはまる全てを検索

End If
End With

Exit Sub
err1:
End Sub
正面からの行削除のプログラムは難しい。上記も不完全箇所を含むかもしれない。
フラグを一旦立てる方法などを薦める。
＝＝＝
例データ
1 1 1 1 1
2 2 2 2 2
3 aa
4 3 3 3 3
5 4 4 4 4
6 aadd aa
7 5 5 5 5
8 6 6 6 6
9 7 7 7 7
10 aa
11 8 8 8 8
12 9 9 9 9
13 10 10 10 10
14 aa aaxc
15 11 11 11 11
結果
1 1 1 1 1
2 2 2 2 2
4 3 3 3 3
5 4 4 4 4
7 5 5 5 5
8 6 6 6 6
9 7 7 7 7
11 8 8 8 8
12 9 9 9 9
13 10 10 10 10
15 11 11 11 11
ーー
見つかった１行上を削除は（2行だけ修正）
Sub test02()
Dim c As Range
With Worksheets("Sheet1").Range("a1:F14") '---このセル範囲が対象
Set c = .Find(What:="aa", LookIn:=xlValues, _
LookAt:=xlPart) '---cに検索結果を格納
If Not c Is Nothing Then '---条件に当てはまるセルがあれば
firstAddress = c.Address '---最初のセルのアドレスを覚える
B = Worksheets("Sheet1").Range("A" & c.Row).Address
c.Offset(-1, 0).EntireRow.Delete
Worksheets("Sheet1").Range(B).Activate
Do '---do...Loopステートメント
On Error GoTo err1
Set c = .FindNext(ActiveCell) '---今見つけたセルから次のセルを検索
If Not c Is Nothing And c.Address <> firstAddress Then
B = Worksheets("Sheet1").Range("A" & c.Row).Address
c.Offset(-1, 0).EntireRow.Delete
MsgBox Worksheets("Sheet1").Range(B).Address
Worksheets("Sheet1").Range(B).Activate
Else
Exit Do
End If
Loop '----条件に当てはまる全てを検索

End If
End With
テストデータ
1 1 1 1 1
2 22 22 22 22
3 aa
4 3 3 3 3
5 44 44 44 44
6 aadd aa
7 5 5 5 5
8 6 6 6 6
9 77 77 77 77
10 aa
11 8 8 8 8
12 9 9 9 9
13 100 100 100 100
14 aa aaxc
15 11 11 11 11
結果
1 1 1 1 1
3 aa
4 3 3 3 3
6 aadd aa
7 5 5 5 5
8 6 6 6 6
10 aa
11 8 8 8 8
12 9 9 9 9
14 aa aaxc
15 11 11 11 11

お礼

ありがとうございました！
しかしごめんなさい
なにぶん初心者なものですから、正直難しくて、理解できませんでした…
とにかく、ありがとうございます！