ここから本文です

Excel VBA 「複数ある特定の文字」を含む行以外の削除 【一番参考にした質問...

vba********さん

2017/8/903:54:25

Excel VBA 「複数ある特定の文字」を含む行以外の削除


【一番参考にした質問】
特定の文字がある行以外を削除するマクロ
https://goo.gl/dxv9aB

いろんな質問を参考にして、現在機能としては問題ないのですが、今後のメンテナンス性に欠けるなぁと思い質問させていただきます。

特定の文字が最初は5個程だったのですが、日に日に増えていき、「複数ある特定の文字」が60個程になってしまい、何かいい方法がないか案を頂戴いただければと思います。

現在は以下のようなものを使用しています。改行制限?のようなものがあるみたいで、現在は (※1) のように横にダラダラ長く書いています。

ーーーーーーーーーーーーーーーーーーーー
Sub 行を削除()
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
If InStr(Cells(i, "E"), "000") = 0 And InStr(Cells(i, "E"), "111") = 0 And InStr(Cells(i, "E"), "222") = 0
InStr(Cells(i, "E"), "333") = 0 And And _ (※1)
InStr(Cells(i, "E"), "444") = 0 Then
Rows(i).Delete
End If
Next
Application.ScreenUpdating = True
End Sub
ーーーーーーーーーーーーーーーーーーーー

("000","111","222","333","444") ← このような形式でも

"000"
"111"
"222"
"333"
"444"
↑ このような形式でもいいので、
現在より見やすく、メンテナンス性のよくなる方法を教えていただければと思います。

外部ファイルの読み込みはなしで、記述で対応したいと思っております。

実際のデータは "000" 等の前後に文字があるため、前後にワイルドカードを付けた検索?になります。

閲覧数:
1,150
回答数:
4
お礼:
250枚

違反報告

ベストアンサーに選ばれた回答

sk_********さん

編集あり2017/8/906:57:54

次のような方法で、キーになるデータを管理(記述)するのはどうでしょうか?

Sub Sample() '特定の文字が含まれない行を選択(削除)
Dim varKey As Variant
varKey = Array("000", "111", "222", "333", "444") 'ここに追加していく
Dim rA As Range, r As Range, rU As Range, i As Long, f As Boolean
Set rA = Range("E1", Cells(Rows.Count, "E").End(xlUp)) 'データ範囲
For Each r In rA
f = False
For i = LBound(varKey) To UBound(varKey)
If InStr(r.Value, varKey(i)) > 0 Then
f = True: Exit For
End If
Next
If Not f Then
If rU Is Nothing Then Set rU = r Else Set rU = Union(rU, r)
End If
Next
If rU Is Nothing Then Exit Sub
rU.EntireRow.Select '行を削除する場合は rU.EntireRow.Delete
End Sub

尚、マクロで行を削除すると、Excelの元に戻す機能が使えないので、マクロで該当の行を選択し、手動でまとめて行を削除する方法が良いと思います。
また、(記述はしていませんが)キーになるデータをコード内ではなく、とあるシートのセルで管理する方法も良いと思います。

  • 質問者

    vba********さん

    2017/8/910:29:38

    早々の返答ありがとうございます。
    理想に近い形です。

    今日、明日と仕事がお休みなので、明後日確認してみます。

    毎日ログファイルをCSV形式で、約20000行保存しておりその中から必要なデータだけがあれば後処理ができるので、今のところは外部に検索結果を記述するよりもVBA内に記載している方が使い勝手が良いのです。(私以外の人間はパソコンが苦手なので・・・)

  • その他の返信を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2017/8/10 14:53:35

sk_tamotuさん

本当にありがとうございました。
当初の私の要望どおりのものができ、さらにスピードもすごい!

私と同じような悩みがある人は、返信の中にある、「Sample3」を使用してください。

ベストアンサー以外の回答

1〜3件/3件中

並び替え:回答日時の
新しい順
|古い順

プロフィール画像

カテゴリマスター

lin********さん

2017/8/910:01:51

私は、普段なら、

a = Array("000","111","222","333","444")

としますが、今回のように、「60個」もあるのでしたら、別シートの列「A」に列挙されるのがいいと思います。

そうしておいて、

Dim s1 As Worksheet, s2 As Worksheet
Dim c as Integer, i As Long, j As Long
Set s1 = Worksheets("Sheet1")
Set s2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
For i = s1.Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
c = 0
For j = 1 to s2.Cells(Rows.Count, "A").End(xlUp).Row
If InStr(s1.Cells(i, "E").Value, s2.Cells(j, "A").Value) > 0 Then
c = 1
Exit For
End If
Next j
If c = 1 Then
s1.Rows(i).Delete
End If
Next i

で、どうでしょうか?

まず、「Sheet1」と「Sheet2」を、それぞれ「s1」、「s2」にセットしておきます。

こうしておけば、どちらのシートがアクティブになっているかなど、気にする必要がありません。

「s1」と書けば、「Sheet1」のことです。

もちろん、左端から順番に「Worksheets(1)」「Worksheets(2)」でも構いません。

c = 0

「フラグ」と呼ばれる方法をとります。

For j = 1 To s2.Cells(Rows.Count, "A").End(xlUp).Row

「Sheet2」の列「A」に関して、1行目から最終行まで処理。

If InStr(s1.Cells(i, "E").Value, s2.Cells(j, "A").Value) > 0 Then

「Sheet1」の「i」行目の値と「Sheet2」の「j」行目の値で調べて、もし、「存在したら」

c = 1
Exit For

フラグを立てて、それ以上、調べる必要がないので、「For j =~」から抜け出しています。

End If
Next j

を、「Sheet2」に列挙された「特定の文字」について繰り返しています。

If c = 1 Then

ここまできて、「c = 0」なら、「存在しなかった」ということですが、今は、「存在した」場合ですので、「If c = 1 Then」となります。

s1.Rows(i).Delete

「Sheet1」の、その行を削除しています。

End If
Next i

を、「Sheet1」の最終行まで繰り返しています。

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

kik********さん

2017/8/909:12:18

以下でどうなりますか

処理対象のシート名:Sheet1
条件を記述しておくシート:Sheet2
A1 ~ Axxx に、"000" / "111" 等記述しておく

これを条件に、確認してみます

新規ファイルの標準モジュールに以下を記述して
testData で確認用データを作成します
Sheet2 の A1 ~ Axxx に、残す語を記述し Samp1 を実行してみます

説明が必要なら、返信いただければと・・・

どうなりますか


Option Explicit

Public Sub Samp1()
   Dim dic As Object
   Dim vA As Variant, vW As Variant, v As Variant
   Dim i As Long, j As Long, k As Long

   Set dic = CreateObject("Scripting.Dictionary")

   With Worksheets("Sheet1")
      With .UsedRange
         j = .Columns.Count + 1
         With .Columns(1)
            vA = .Offset(, Range("E1").Column - .Column).Value
         End With
         vW = WorksheetFunction.Transpose(vA)

         With Worksheets("Sheet2")
            With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
               For i = 1 To .Rows.Count
                  For Each v In Filter(vW, .Cells(i, "A").Text)
                     dic(v) = Empty
                  Next
               Next
            End With
         End With

         For i = 1 To UBound(vA)
            If (dic.Exists(vA(i, 1))) Then
               vA(i, 1) = i
            Else
               vA(i, 1) = ""
            End If
         Next

         Application.ScreenUpdating = False
         With .Resize(, j)
            .Columns(j).Value = vA
            .Sort .Cells(j), xlAscending, Header:=xlNo
            On Error Resume Next
            .Columns(j).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            On Error GoTo 0
            .Columns(j).ClearContents
         End With
         Application.ScreenUpdating = True
      End With
   End With

   Set dic = Nothing
End Sub


' 確認用データ作成

Public Sub testData()
   Const CRH As Long = 5000
   Const CCW As Long = 5
   Dim vA(1 To CRH, 1 To CCW) As Variant
   Dim sS As String
   Dim i As Long, j As Long, k As Long, n As Long

   Randomize

   n = Range("E1").Column
   k = Int(n * Rnd())
   For i = 1 To CRH
      For j = 1 To CCW
         If (j + k = n) Then
            If (Rnd() < 0.5) Then
               vA(i, j) = "E" _
                  & String(Int(5 * Rnd()) + 1, CStr(i Mod 10))
            Else
               vA(i, j) = "AB" & Int(10000 * Rnd()) + 1
            End If
         Else
            vA(i, j) = Cells(i, j + k).Address(False, False)
         End If
      Next
   Next

   With Worksheets("Sheet1")
      .Cells.Delete
      .Range("A1").Offset(, k).Resize(CRH, CCW).Value = vA
      .Columns.AutoFit
   End With
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

web********さん

2017/8/908:35:53

>特定の文字がある行以外を削除

一行ずつ判断処理を行うデータの削除よりは
特定の文字がある行を抽出して、シートを置き換えるほうが遥かに処理は早い

フィルターオプションによる抽出
http://www.eurus.dti.ne.jp/~yoneyama/Excel/filter3.htm#optio_vba

>特定の文字が最初は5個程だったのですが、日に日に増えていき、「複数ある特定の文字」が60個程になってしまい

抽出条件はシート上に設定するので、条件の削除/追加や確認の管理が容易
抽出元のデータをバックアップとして残しておくことも可能なので、条件を変えて再抽出することも可能

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる