人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

指定した約1000のキーワードを含む行以外を削除したいです

今、Sheet1のA列にずらりとデータが2万行ほど並んでいます。
そしてSheet2のC列に、1000行ほどデータが並んでおります。

この状況におきまして、Sheet2のC列の1000行(1000セル)のデータの各文字列が、もしSheet1のA列の各セル(20000セル)に含まれていた場合。
該当するA列のデータは残し、それに該当しないセルは、行ごと削除していきたいのです。

そのような処理がマクロ等で可能でしたらお教えいただけないでしょうか。
よろしくお願い致します。


●質問者: moon-fondu
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● a-kuma3
●1500ポイント ベストアンサー

標準モジュールに以下のコードを貼り付けて、Sheet1 を表示している状態で delete_by_keyword_list2 サブルーチンを実行してください。

Sub delete_by_keyword_list2()
 On Error GoTo ErrorHandler

 Application.ScreenUpdating = False

 Dim keyword(), work()

 Set ref_s = Sheets("Sheet2")

  ' C列の最終行を調べる
 last_row = ref_s.Cells(Rows.Count, 3).End(xlUp).Row

 ReDim work(last_row)
 i = 1
 For r = 1 To last_row
 Set cell = ref_s.Cells(r, 3)
 If Not IsEmpty(cell) And cell.Value <> "" Then
 work(i) = cell.Value
 i = i + 1
 End If
 Next

 n = i - 1
 ReDim keyword(1 To n)
 For i = 1 To n
 keyword(i) = work(i)
 Next

 Set re = CreateObject("VBScript.RegExp")
 re.Pattern = Join(keyword, "|")

  ' A列の最終行を調べる
 last_row = Cells(Rows.Count, 1).End(xlUp).Row

 r = 2
 Do While r <= last_row
 deleted = False
 txt = Cells(r, 1).Value
 If Not re.Test(txt) Then  ' ★基本的には、ここを変えただけ
 Cells(r, 1).EntireRow.Delete
 last_row = last_row - 1
 Else
 r = r + 1
 End If
 DoEvents
 Loop

FINAL:
 Set re = Nothing
 Application.ScreenUpdating = True

 Exit Sub

ErrorHandler:
 MsgBox "エラー!"
 GoTo FINAL

End Sub

前回の質問のコードでうまく行ったということなので、正規表現を使ったパターンでやってます。
if 文の条件を反転させただけなのですが、条件が判定すると削除する行の数も反転します。
前回のケースで多いのか、今回の方が多いのかが分からないので、画面表示の更新を止めて、少し早く動作するようにしてみました。

特別に速くはない数年前のノートPC で、キーワードが 1000件、対象のデータが 9000件、削除されるデータが 8900件程度というテストデータで試したところ、40秒くらいで削除が完了しました。
画面更新を活かしたままだと、3分近くかかります (´・ω・`)


moon-fonduさんのコメント
ありがとございます、sheet1は2万行、sheet2は900ぐらいデータがありましたが、5分と少しぐらいでうまく抽出ができました!ほんとに感謝です(^^♪
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ