web-dev-qa-db-fra.com

Méthode efficace pour supprimer la ligne entière si la cellule ne contient pas '@'

Je crée un sous-marin rapide pour effectuer une vérification de validité des courriels. Je souhaite supprimer des lignes entières de données de contact qui ne contiennent pas de "@" dans la colonne "E". J'ai utilisé la macro ci-dessous, mais elle fonctionne trop lentement car Excel déplace toutes les lignes après la suppression.

J'ai essayé une autre technique comme celle-ci: set rng = union(rng,c.EntireRow), puis en supprimant toute la plage, mais je ne pouvais pas empêcher les messages d'erreur.

J'ai également essayé d'ajouter simplement chaque ligne à une sélection, puis de tout supprimer après avoir tout sélectionné (comme dans Ctrl + Select), mais je n'ai pas trouvé la syntaxe appropriée pour cela.

Des idées? 

Sub Deleteit()
    Application.ScreenUpdating = False

    Dim pos As Integer
    Dim c As Range

    For Each c In Range("E:E")

        pos = InStr(c.Value, "@")
        If pos = 0 Then
            c.EntireRow.Delete
        End If
    Next

    Application.ScreenUpdating = True
End Sub
excelvbaexcel-vba
9
Parseltongue

Vous n'avez pas besoin d'une boucle pour le faire. Un filtre automatique est beaucoup plus efficace. (similaire à curseur vs clause where en SQL)

Filtrez automatiquement toutes les lignes qui ne contiennent pas "@" puis supprimez-les comme suit:

Sub KeepOnlyAtSymbolRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long

    Set ws = ActiveWorkbook.Sheets("Sheet1")

    lastRow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row

    Set rng = ws.Range("E1:E" & lastRow)

    ' filter and delete all but header row
    With rng
        .AutoFilter Field:=1, Criteria1:="<>*@*"
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ' turn off the filters
    ws.AutoFilterMode = False
End Sub

REMARQUES:

  • .Offset(1,0) nous empêche de supprimer la ligne de titre
  • .SpecialCells(xlCellTypeVisible) spécifie les lignes qui restent après l'application du filtre automatique
  • .EntireRow.Delete supprime toutes les lignes visibles à l'exception de la ligne de titre

Parcourez le code et vous pouvez voir ce que chaque ligne fait. Utilisez F8 dans l'éditeur VBA.

18
Jon Crowell

Avez-vous essayé un filtre automatique simple en utilisant " @ " comme critère puis utilisez

specialcells(xlcelltypevisible).entirerow.delete

note: il y a des astérisques avant et après le @ mais je ne sais pas comment les empêcher d'être analysés!

3
JosieP

À l'aide d'un exemple fourni par l'utilisateur shahkalpesh, j'ai créé la macro suivante avec succès. Je suis toujours curieux d'apprendre d'autres techniques (comme celle référencée par Fnostro dans laquelle vous effacez du contenu, triez puis supprimez). Je suis nouveau dans VBA, donc tous les exemples seraient très utiles. 

   Sub Delete_It()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With ActiveSheet
        .Select
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        .DisplayPageBreaks = False

        'Firstrow = .UsedRange.Cells(1).Row
        Firstrow = 2
        Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row

        For Lrow = Lastrow To Firstrow Step -1
            With .Cells(Lrow, "E")
                If Not IsError(.Value) Then
                    If InStr(.Value, "@") = 0 Then .EntireRow.Delete
                End If
            End With
         Next Lrow
        End With

    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub
2
Parseltongue

Lorsque vous travaillez avec plusieurs lignes et plusieurs conditions, il est préférable d’utiliser cette méthode de suppression de lignes.

Option Explicit

Sub DeleteEmptyRows()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim i&, lr&, rowsToDelete$, lookFor$

    '*!!!* set the condition for row deletion
    lookFor = "@"

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lr = ws.Range("E" & Rows.Count).End(xlUp).Row

    ReDim arr(0)

    For i = 1 To lr
     If StrComp(CStr(ws.Range("E" & i).Text), lookFor, vbTextCompare) = 0 then
       ' nothing
     Else
        ReDim Preserve arr(UBound(arr) + 1)
        arr(UBound(arr) - 1) = i
     End If
    Next i

    If UBound(arr) > 0 Then
        ReDim Preserve arr(UBound(arr) - 1)
        For i = LBound(arr) To UBound(arr)
            rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
        Next i

        ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Delete Shift:=xlUp
    Else
        Application.ScreenUpdating = True
        MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
        Exit Sub
    End If

    If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
    Set ws = Nothing
End Sub
1
user2140173

Au lieu de boucler et de référencer chaque cellule 1 par 1, saisissez tout et placez-le dans un tableau variant; Puis bouclez le tableau variant.

Entrée:

Sub Sample()
    ' Look in Column D, starting at row 2
    DeleteRowsWithValue "@", 4, 2
End Sub

Le vrai ouvrier:

Sub DeleteRowsWithValue(Value As String, Column As Long, StartingRow As Long, Optional Sheet)
Dim i As Long, LastRow As Long
Dim vData() As Variant
Dim DeleteAddress As String

    ' Sheet is a Variant, so we test if it was passed or not.
    If IsMissing(Sheet) Then Set Sheet = ActiveSheet
    ' Get the last row
    LastRow = Sheet.Cells(Sheet.Rows.Count, Column).End(xlUp).Row
    ' Make sure that there is work to be done
    If LastRow < StartingRow Then Exit Sub

    ' The Key to speeding up the function is only reading the cells once 
    ' and dumping the values to a variant array, vData
    vData = Sheet.Cells(StartingRow, Column) _
                 .Resize(LastRow - StartingRow + 1, 1).Value
    ' vData will look like vData(1 to nRows, 1 to 1)
    For i = LBound(vData) To UBound(vData)
        ' Find the value inside of the cell
        If InStr(vData(i, 1), Value) > 0 Then
            ' Adding the StartingRow so that everything lines up properly
            DeleteAddress = DeleteAddress & ",A" & (StartingRow + i - 1)
        End If
    Next
    If DeleteAddress <> vbNullString Then
        ' remove the first ","
        DeleteAddress = Mid(DeleteAddress, 2)
        ' Delete all the Rows
        Sheet.Range(DeleteAddress).EntireRow.Delete
    End If
End Sub
0
Profex