Faster way to delete rows based on criteria?

[labrint]

I need to do this is a faster way, please help


Dim LastRow As Long, x As LongDim ws As Worksheet
Set ws = ActiveSheet


LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row


For x = 1 To LastRow
If ws.Cells(x, "A") = "Products Sold by Location" Then
ws.Rows(x).EntireRow.Delete
End If
Next x


For x = 1 To LastRow
If ws.Cells(x, "A") = "Location" Then
ws.Rows(x).EntireRow.Delete
End If
Next x


For x = 1 To LastRow
If ws.Cells(x, "A") = "Code" Then
ws.Rows(x).EntireRow.Delete
End If
Next x

For x = 1 To LastRow
If ws.Cells(x, "A") = "Criteria" Then
ws.Rows(x).EntireRow.Delete
End If
Next x

For x = 1 To LastRow
If ws.Cells(x, "A") = "Total" Then
ws.Rows(x).EntireRow.Delete
End If
Next x

For x = 1 To LastRow
If ws.Cells(x, "A") = "" Then
ws.Rows(x).EntireRow.Delete
End If
Next x


Application.ScreenUpdating = False
ws.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

[rollis13]

Have a try with my macro on a test file and see if it does what you need (and faster). Please note that I'm assuming you have headers in row 1 and data from row 2 and down.
Option Explicit
Sub DeleteRowsByArray()
Dim myArr As Variant
Dim LastRow As Long, x As Long, ws As Worksheet
Set ws = ActiveSheet
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
myArr = Array("Products Sold by Location", "Location", "Code", "Criteria", "Total", "")
With ws
For x = LBound(myArr) To UBound(myArr)
.AutoFilterMode = False
With .Range("A2", .Range("A" & LastRow)) 'data from row 2 and down
.AutoFilter 1, myArr(x)
On Error Resume Next
If myArr(x) = "" Then
.Offset(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete '4
Else
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete '12
End If
On Error GoTo 0
End With
Next x
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

[Paul_Hossler]

When you delete rows one at a time like that, you should start at the bottom and go up





LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For x = LastRow to 1 Step -1



But this way is faster



Option Explicit


Sub Test()
Dim ws As Worksheet

Set ws = ActiveSheet

Application.ScreenUpdating = False


With ws.Columns(1)
.Replace What:="Code", Replacement:=True, LookAt:=xlWhole
.Replace What:="Products Sold by Location", Replacement:=True, LookAt:=xlWhole
.Replace What:="Location", Replacement:=True, LookAt:=xlWhole
.Replace What:="Criteria", Replacement:=True, LookAt:=xlWhole
.Replace What:="Total", Replacement:=True, LookAt:=xlWhole
.Replace What:="", Replacement:="#####", LookAt:=xlWhole
.Replace What:="#####", Replacement:=True, LookAt:=xlWhole
'clear any empty, but text i.e. 0 length strings
Call .Replace(vbNullString, "###ZZZ###", LookAt:=xlWhole)
Call .Replace("###ZZZ###", vbNullString, LookAt:=xlWhole)

On Error Resume Next
.SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With


Application.ScreenUpdating = True
End Sub

[SamT]

There may be errors: I don't have Office on this computer, but try. . .


Sub SamT()
Dim arrA as Variant
Dim Ws As Worksheet
Dim LastCell As Range
Set ws = ActiveSheet
Dim Deleters as Variant
Dim i as Long, j as Long
Dim Calc as Long

Deleters = Array("Products Sold by Location",""Location","Code",Criteria","Total")

With ws
Set LastCell = .Cells(Rows.Count, "A").End(xlUp)
arrA =.Range(cells(2, "A"), LastCell.Value)
End With
With Application
Calc = .Calculation
.Calculation = Manual
.EnableEvents = False
.ScreenUpdating = False
End With

For i = LBound(arrA) to UBound(arrA)
For j = Lbound(Deleters) to UBound(Deleters)
If Deleters(j) = arrA(i) Then arrA(i) = ""
Next j
Next i

With ws
.Range("A2").Resize(UBound(arrA),1) = arrA
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

With Application
.Calculation = Calc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[snb]

Sub M_snb()
c00 = "_Products Sold by Location_Location_Code_Criteria_Total_"

with activesheet.usedrange.columns(1)
sn = .value
for j = 1 to ubound(sn)
if instr(c00,"_" & sn(j,1) & "_") then sn(j,1)=""
next

.value = sn
.specialcells(4).entirerow.delete
end with
End Sub

[jolivanes]

Or

Sub Delete_Specific_Values()
Dim spVal As Variant
Dim i As Long
spVal = Array("Products Sold by Location", "Location", "Code", "Criteria", "Total", "") '<----- Add as many Values as required
With ActiveSheet.Columns(1)
For i = LBound(spVal) To UBound(spVal)
.Replace spVal(i), "=1/0", xlWhole, , False, False, False
Next i
.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End With
End Sub

[p45cal]

and another. Assumes header in row 1:
Sub blah()
Crit1 = Array("Code", "Criteria", "Location", "Products Sold by Location", "Total", "=")
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=Crit1, Operator:=xlFilterValues
With .AutoFilter
Intersect(.Range, .Range.Offset(1)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range.AutoFilter
End With
End With
End Sub

If there's no header this next one will delete row 1 regardless:

Sub blah2()
Crit1 = Array("Code", "Criteria", "Location", "Products Sold by Location", "Total", "=")
With ActiveSheet
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=Crit1, Operator:=xlFilterValues
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub

[snb]

@p45

Nice

Sub M_snb()
With UsedRange.Columns(1)
.AutoFilter 1, Array("Code", "Criteria", "*Location", "Total", "="), 7
.SpecialCells(12).EntireRow.Delete
.AutoFilter
End With
End Sub
Headers excluded:

Sub M_snb()
With UsedRange.Columns(1)
.AutoFilter 1, Array("Code", "Criteria", "*Location", "Total", "="), 7
.offset(1).SpecialCells(12).EntireRow.Delete
.AutoFilter
End With
End Sub

[jolivanes]

After a week of checking which code to use, labrint has not made up his/her mind yet because no "Thank you for your efforts and great help" yet.

[snb]

Lost in the lab(y)rint ?