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

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

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

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

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2016/06/30 09:17:48
  • 終了:2016/07/02 03:11:26

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4325ベストアンサー獲得回数17732016/07/01 15:39:51

ポイント1500pt

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

Sub delete_by_keyword_list()

    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 re.Test(txt) Then
            Cells(r, 1).EntireRow.Delete
            last_row = last_row - 1
        Else
            r = r + 1
        End If
        DoEvents
    Loop

    Set re = Nothing

End Sub

以下の前提、制約があります。

  • Sheet2 には見出し行が無く、キーワードは 1行目から始まっている
  • Sheet2 のキーワードのC列には、空白セルが入っていることを考慮している
  • キーワードには、正規表現で特別な意味を持つピリオドやパイプ記号などは入っていない

三番目が、もしかしたら要件を満たせないかもしれません。
実は、InStr 関数を使って素直に引き当てるようなマクロも書いてみたのですが、ちょっと遅すぎるので、正規表現を使うパターンにしてみました。
特別に速くはない数年前のノートPC で、キーワードが 1000件、対象のデータが 9000件、削除されるデータが 100件程度というテストデータで試したところ、以下のような結果になりまして。

  • 二重のループで InStr で引き当てる:約 6 分(360 秒)
  • 正規表現を使う(回答のコード):約 10 秒

また、削除される行が多いと、この回答で書いたコードでも数分のオーダで実行時間がかかることがあります。
何度も使うようなマクロで、削除する行が多い場合には、補足をお願いします。


データを削除してしまうマクロなので、バックアップは確実にお願いします。

id:moon-fondu

a-kuma3さんありがとうございます、うまくいきました(^^;)
ちなみになのですが…もう1つ、質問がありまして。
新しく立ち上げましたので、a-kuma3さんの高度な技術でお力添えをいただけますと幸いです。
http://q.hatena.ne.jp/1467396550
よろしくお願い致しますm(__)m

2016/07/02 03:10:46

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません