Modo efficiente per cancellare l’intera riga se la cella non contiene ‘@’

Sto creando un sub veloce per fare un controllo di validità delle e-mail. Voglio eliminare intere righe di dati di contatto che non contengono un ‘@’ nella colonna ‘E’. Ho usato la macro sottostante, ma funziona troppo lentamente perché Excel sposta tutte le righe dopo l’eliminazione.

Ho provato un’altra tecnica come questa: set rng = union(rng,c.EntireRow) , e in seguito cancellare l’intero intervallo, ma non sono riuscito a impedire i messaggi di errore.

Ho anche sperimentato con l’aggiunta di ogni riga a una selezione, e dopo che tutto è stato selezionato (come in ctrl + select), successivamente cancellandolo, ma non sono riuscito a trovare la syntax appropriata per quello.

Qualche idea?

 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 

Non hai bisogno di un loop per farlo. Un autofilter è molto più efficiente. (simile alla clausola cursor vs. where in SQL)

Inserisci automaticamente tutte le righe che non contengono “@” e quindi eliminale in questo modo:

 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 

GLI APPUNTI:

  • .Offset(1,0) ci impedisce di cancellare la riga del titolo
  • .SpecialCells(xlCellTypeVisible) specifica le righe che rimangono dopo l’applicazione del filtro automatico
  • .EntireRow.Delete elimina tutte le righe visibili tranne la riga del titolo

Passa attraverso il codice e puoi vedere cosa fa ogni linea. Usa F8 nell’editor VBA.

Hai provato un semplice filtro automatico usando ” @ ” come i criteri quindi utilizzare

 specialcells(xlcelltypevisible).entirerow.delete 

nota: ci sono degli asterischi prima e dopo la @ ma non so come impedirgli di essere analizzati!

Usando un esempio fornito dall’utente shahkalpesh, ho creato con successo la seguente macro. Sono ancora curioso di apprendere altre tecniche (come quella a cui fa riferimento Fnostro in cui si deseleziona il contenuto, si ordina e quindi si elimina). Sono nuovo di VBA quindi qualsiasi esempio sarebbe molto utile.

  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 

Quando lavori con molte righe e molte condizioni, è meglio usare questo metodo di eliminazione delle righe

 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 

Invece di fare il ciclo e fare riferimento a ciascuna cella 1 per 1, prendi tutto e mettilo in una matrice variante; Quindi loopare l’array variante.

Antipasto:

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

Il vero lavoratore:

 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