[[20130529095304]]　『＊があれば行を削除』（Bo）　ページの最後に飛ぶ

『＊があれば行を削除』（Bo）
Excel2010 Windows 7
A列 B列
ID 名前
があります。（実際はたくさんの列がありますが）名前には山田太郎＊＊＊
や＊高橋太郎や山田花子のように＊が入っている方がいます。
＊が一文字でもあったら行を削除というVBAを作成してみたのですが、
根こそぎ行を削除してしまいます。

一部分ですが、

 ElseIf cells(i, 2) Like "*" Then
 Rows(i).Delete Shift:=xlUp

なにが悪いのでしょうか。＊の所に他の文字をいれてテストするとうまくいきます。
ご教示ください

 Like演算子では * や　? や # は特別な文字。
http://pub.ne.jp/arihagne/?entry_id=2117904

 追記で老婆心

 マクロ内の i のループは、当然、一番下から上に向かって処理しているよね？

 (ぶらっと)

 If InStr(文字列,"*")>0 Then
 や
 If Replace(文字列,"*","") <> 文字列 Then
 といった * を通常の文字として扱う関数を使う方法もありかも。
 (Mook)

本当にありがとうございます。（bo）
できました。
書籍を見ながら作成してたので、助かりました。
もうひとつお願いします。

さっきの話しのつづきなのですが、
データが９万件ほどありまして、
列の先頭に9　7　0　ｈがあれば行削除
又は
名前欄に＊があればデータを行を削除（さきほど教えていただきました。）
というのを見よう見まねで作成してみましたが、
まったくVBAが終了しません（ものすごく時間がかかります。）。なんとか早くできまでんしょうか。

 　 Dim i As Long
    Dim lastrow As Long
    Dim A As Variant
    Dim myCnt As Long

    A = Range("A1:L150000").Value

    Worksheets("Sheet3").Activate

    'スクリーン表示の更新を抑止
    Application.ScreenUpdating = False

    lastrow = Range("B170000").End(xlUp).Row

    For i = lastrow To 1 Step -1

    'If Left(Cells(i, 2).Value, 1) = "9" Then
     If Left(A(i, 2), 1) = "9" Then
        Rows(i).Delete Shift:=xlUp

    'ElseIf Left(Cells(i, 2).Value, 1) = "7" Then
     ElseIf Left(A(i, 2), 1) = "7" Then
            Rows(i).Delete Shift:=xlUp

    'ElseIf Left(Cells(i, 2).Value, 1) = "h" Then
     ElseIf Left(A(i, 2), 1) = "h" Then
            Rows(i).Delete Shift:=xlUp

    'ElseIf Left(Cells(i, 2).Value, 1) = "0" Then
     ElseIf Left(A(i, 2), 1) = "0" Then
            Rows(i).Delete Shift:=xlUp

    'ElseIf Cells(i, 12) Like "*＊*" Then
     ElseIf A(i, 12) Like "[*＊*]" Then
     Rows(i).Delete Shift:=xlUp
    End If
    Next i
    'スクリーン表示の更新の抑止を解除
    Application.ScreenUpdating = True

    End Sub

 気になった点がありますが、対象は Sheet3 なのですか？ であれば、
    Worksheets("Sheet3").Activate
 は処理の最初にもっていったほうがよいと思います。

 それからエスケープしたいのは＊だけであれば、Like "*[＊]*" then のような気がします。

 それはさておき、処理が遅いのは削除に時間がかかるので、まとめて削除するようにしたら
 どうでしょうか。
 (Mook)

 Sub DeleteLines()
    Worksheets("Sheet3").Activate

    Dim A
    A = Range("A1:L150000").Value

    'スクリーン表示の更新を抑止
    Application.ScreenUpdating = False

    Dim lastrow As Long
    lastrow = Range("B170000").End(xlUp).Row

    Dim i As Long
    Dim dl As Range
    For i = lastrow To 1 Step -1
        If InStr("97h0", Left(A(i, 2), 1)) > 0 Or A(i, 12) Like "*[＊]*" Then
            If dl Is Nothing Then
                Set dl = Cells(i, "A")
            Else
                Set dl = Union(dl, Cells(i, "A"))
            End If
        End If
    Next
    dl.EntireRow.Delete

    'スクリーン表示の更新の抑止を解除
    Application.ScreenUpdating = True
 End Sub

 参考出品

 処理時間の短縮化ということであれば以下はどうだろう。
 元シートをSheet1 だとして、指定のものを削除した残りがSheet2に作成される。
 ただし、１行目をタイトル行にしてもらう必要はあるけど。

 ・Sheet2 の　A列～L列をクリア
 ・Sheet2 の N2 に　=AND(Sheet1!B2=SUBSTITUTE(Sheet1!B2,"*",""),AND(LEFT(Sheet1!B2,1)<>"ｈ",LEFT(Sheet1!B2,1)<>"0",LEFT(Sheet1!B2,1)<>"7",LEFT(Sheet1!B2,1)<>"9"))
 ・Sheet2 を表示した状態で　データタブ　のフィルターグループの詳細設定（フィルターオプション)
 　リスト範囲(L) を Sheet1 の A:L
 　検索条件範囲(C) を Sheet2の N1:N2
 　指定した範囲(O) にチェックをして、抽出範囲(T) に Sheet2 の A1
 　これで　ＯＫボタン

 マクロが希望ならこの一連の操作をマクロ記録すれば、基本的なコードは生成されるので、あとはお化粧直し。

 (ぶらっと)

返信ありがとうございます(bo)

(Mook)様

さそっく行ってみたのですが、

 dl.EntireRow.Deleteの所でエラー91オブジェクト変数又はwithブロック変数****
とでます。対処方法をおしえていただきますと幸いです。

 横から失礼

 該当のものがなければ dl は Nothing なので

 If Not dl Is Nothing Then dl.EntireRow.Delete

 (ぶらっと)

 うーん、原因は分かりませんが、
 10万行でやってみると、だんだん遅くなりますね。
 UNION で扱うセルが多数になると遅いのかな？
 Like 演算子もコストが高いようなので変更してみました。

 下記でどうでしょうか。

 #ぶらっとさんの指摘も気になっていたので、変更しています。
 (Mook)

 Sub DeleteLines()
    Worksheets("Sheet3").Activate

    Dim A
    A = Range("A1:L150000").Value

    'スクリーン表示の更新を抑止
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Dim lastrow As Long
    lastrow = Range("B170000").End(xlUp).Row

    Dim i As Long
    Dim cnt As Long
    Dim dl As Range
    For i = lastrow To 1 Step -1
        If InStr("97h0", Left(A(i, 2), 1)) > 0 Or InStr(A(i, 12), "＊") > 0 Then
            If dl Is Nothing Then
                Set dl = Cells(i, "A")
            Else
                Set dl = Union(dl, Cells(i, "A"))
                cnt = cnt + 1
                If cnt > 100 Then
                    dl.EntireRow.Delete
                    Set dl = Nothing
                    cnt = 0
                End If
            End If
        End If
    Next
    If Not dl Is Nothing Then
        dl.EntireRow.Delete
    End If

    'スクリーン表示の更新の抑止を解除
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub

 >UNION で扱うセルが多数になると遅いのかな？

 そうですねぇ。数が多くなると、UNIONコストが、行ごとの削除コストの節約を相殺してしまうぐらい
 重い処理のようですね。

 (ぶらっと)

 上でリコメンドしたフィルターオプションは、トライする価値はあると思うので、時間があるときにぜひ試してほしい。
 それとは別に、以下。フィルターオプションと同じように、【必要なものを残す】構え。

 Sub Sample()
    Dim v As Variant
    Dim w() As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim d As Variant
    Dim ng As Boolean

    With Sheets("Sheet3")
        v = .Range("A1", .UsedRange).Value
        ReDim w(1 To UBound(v, 1), 1 To UBound(v, 2))
        For i = 1 To UBound(v, 1)
            ng = False
            d = v(i, 2)
            If InStr(d, "*") Then
                ng = True
            Else
                Select Case Left(d, 1)
                    Case "0", "7", "9", "ｈ": ng = True
                End Select
            End If
            If Not ng Then
                k = k + 1
                For j = 1 To UBound(v, 2)
                    w(k, j) = v(i, j)
                Next
            End If
        Next

        .Range("A1", .UsedRange).Value = w

    End With

 End Sub

 (ぶらっと)

 単純に

 If (Cells(i, 2).Value Like "[790h]*") + (Cells(i, 2).Value Like "*[＊[*]*") Then Rows(i).Delete
 (seiya)

返信が遅くなりました(bo)

確認させていただきました。早くなってびっくりです。
皆様、本当にありがとうございました。

コメント返信：

[ 一覧(最新更新順) ]

[[20130529095304]] 『＊があれば行を削除』（Bo） ページの最後に飛ぶ

[[20130529095304]]　『＊があれば行を削除』（Bo）　ページの最後に飛ぶ