EXCEL VBA 条件に合致しない行を削除したい

質問

超初心者です。どうか教えてください・・・m(_ _)m

Ａ列　　　Ｂ列　　　・・・・・
1234567　 2345678
9876543　 8765432
　・　　　　・
　・　　　　・

といった、表（数千行規模）があります。
Ａ列とＢ列には７桁の数字があります。
Ａ列とＢ列には途中ブランクのセルもあります。

Ａ列またはＢ列のどちらかにも、
複数の範囲条件（数字）に合致しない行を削除したいです。
Ａ列またはＢ列のどちらかに合致すればその行を残します。

複数の範囲条件（数字）
（例）
　1000000～1000009
　2000100～2000199
　　　　・
　　　　・
　　十数個あります。

何卒、宜しくお願い致します。・・・m(_ _)m

回答No.4

mitarashi · ベストアンサー

#2です。
条件の後出しをしないで、ご自分でアレンジする才覚を持っていただかないと、後々メンテナンス出来ないで困りますよ。
コード中のコメントを読んでから、バックアップを取った上で実行して下さい。
Sub test()
Dim ref(9999999) As Boolean
Dim criteriaRange As Range
Dim targetRange As Range
Dim myRow As Range
Dim buf As Variant
Dim i As Long

With Sheets(1)
'最初のシートのA3からの処理に変更
Set targetRange = Range(.Range("A3"), .Range("B" & .Rows.Count).End(xlUp))
End With
buf = targetRange
With Sheets(2)
Set criteriaRange = Range(.Range("A1"), .Range("B" & .Rows.Count).End(xlUp))
End With
For Each myRow In criteriaRange.Rows
For i = myRow.Cells(1) To myRow.Cells(2)
ref(i) = True
Next i
Next myRow
For i = 1 To UBound(buf, 1)
If ref(CLng(buf(i, 1))) Or ref(CLng(buf(i, 2))) Then
Else
buf(i, 1) = Empty
buf(i, 2) = Empty
End If
Next i
'最初のシートの行削除に変更（必ずバックアップを取ってから試行の事）
targetRange = buf
targetRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

お礼

mitarashiさま
　この度は度々お力を頂き、本当にありがとうございました。
条件不足等、何度もお手を煩わせてしまい、大変恐縮でございます。
頂きましたアドバイスで欲しいデータの抽出ができまして、感動しました。
大変感謝しております。
躓きつつも、自分なりに掘り下げ、目的に達することが、プログラミングの面白さでしょうか・・・
今回、このことを体験できた気がします。
本当にいろいろとありがとうございました。

回答No.3

mitarashi

#2です。
A,B列に入っている「数字」のデータ型の問題でしょうか、
If ref(buf(i, 1)) Or ref(buf(i, 2)) Then
のところを
If ref(CLng(buf(i, 1))) Or ref(CLng(buf(i, 2))) Then
にしてみて下さい。
それでもダメなら、コードが中断したところで、buf(i,1)の値がマウスポインタを持って行くと表示されると思いますので、どんな値が入っているかお知らせ下さい。

お礼

mitarashiさま
　御回答いただきまして本当にありがとうございますm(_ _)m
　ご指示のとおり変更し試しましたところ、同様の結果となりました。
マウスポインタによるbuf(i,1)の値は、
buf(i,1)=”文字列”（文字列＝チェック対象データシートのA1セルに記載の表の題名）
でした。
ちなみに、チェック対象データシートの構成は、
・A1セルに表の題名
・2行目に表の項目名（A2～X2）
・3行目以降にデータ領域
となっております。

度々申し訳ありません。
何卒、お力を・・・m(_　_)m

回答No.2

mitarashi

興味本位でやってみましたので、自称超初心者さん向けではないと思います。メモリー大盤振る舞いの案です。スピード命のつもりですので、親切な方から分かり易い回答があったら、処理速度を比べてみて下さい。
'Sheets(1)にチェック対象のデータがある
'Sheets(2)のA列に範囲の最初、B列に範囲の最後の値が入っている
'A1が1000000、B1が1000009という様に。以下下方に続く
'Sheets(3)に削除されなかったデータを貼り付ける（Sheets(1)はいじりません）
'Sheets(1)のブランクの行も削除対象になります。

配列ref()のref(1000000),ref(1000001),...ref(100009)をtrueにしておき、
1234567がこの範囲に含まれるかどうかチェックするには、ref(1234567)がtrueかどうかを見ればよいという案です。
Sub test()
Dim ref(9999999) As Boolean
Dim criteriaRange As Range
Dim targetRange As Range
Dim myRow As Range
Dim buf As Variant
Dim i As Long

With Sheets(1)
Set targetRange = Range(.Range("A1"), .Range("B" & .Rows.Count).End(xlUp))
End With
buf = targetRange
With Sheets(2)
Set criteriaRange = Range(.Range("A1"), .Range("B" & .Rows.Count).End(xlUp))
End With
For Each myRow In criteriaRange.Rows
For i = myRow.Cells(1) To myRow.Cells(2)
ref(i) = True
Next i
Next myRow
For i = 1 To UBound(buf, 1)
If ref(buf(i, 1)) Or ref(buf(i, 2)) Then
Else
buf(i, 1) = Empty
buf(i, 2) = Empty
End If
Next i
Sheets(3).Range(targetRange.Address) = buf
Sheets(3).Range(targetRange.Address).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

お礼

mitarashiさま

　早速の御回答ありがとうございました。
　お時間を割いていただき、プログラムまで組んでいただきまして・・・m(_　_)m
急いでおりましたので、大変ありがたく存じます。
勉強させていただきたいと思います。
ありがとうございました。

補足

mitarashiさま
　お世話になります。
組んでいただきましたプログラムのシート名などを書換え試させていただきました。
実行時エラー'13':型が一致しません。
と出てしまい、デバックすると、
If ref(buf(i, 1)) Or ref(buf(i, 2)) Then
のところで止まってしましました。
本などで解明を試みましたが、
恥ずかしながらマクロのマの字も満足でない私にはなすすべがない状況でございます。
大変お手数をお掛けし恐縮ですが、対処方法をご教授頂けましたら幸いです。
何卒宜しくお願い致します。

回答No.1

mt2008

「教えてください」と、言われても何が判らないのかが書いて無いと答えようが無いです。
とりあえず、やり方が判らないのだと判断してアドバイス。
表を一行づつ見て行って、A列の値、B列の値がどちらも複数の範囲行件に合致しない場合はその行を削除する……と、言う事を地道に繰り返すのが一番簡単。

・「複数の範囲条件」をどこか別のシートに持つ事をお勧めします。
　例えば、Sheet2のA1に1000000、B1に1000009、A2に2000100、B2に2000199、……。

・表を見て行く時は下から上に。上から下に見て行くと、行を削除した時アクティブな行がどこかが判りにくい。

・何千行もあると、画面更新するだけで時間が掛かるので、Application.ScreenUpdating = Falseで画面の更新を止め、最後にApplication.ScreenUpdating = Trueとして戻すと早い。

・複数の範囲条件に合致するか否かは、functionで作ってサブルーチン化した方が判りやすい。
　＃例：引数で数値を渡すと範囲条件のどれかに合致するならTrueを返す

お礼

mt2008さま

　早速の御回答ありがとうございましたm(_　_)m。
　まだまだ何がわからないかもわからないほどの初心者でして、
質問がわかりづらく恐縮でした。。
頂きましたアドバイスでいろいろ試して行きたいと思います。
ありがとうございました。