PDA

View Full Version : Solved: Speed up excel code



copyt
04-14-2012, 05:24 AM
Hello all, I have a code (recorded macro) to search and delete rows containing certain texts. Since the data is in rangeA1:A30000 so it takes a long time to finish. Any idea to speed it up? Any help/suggestion would be appreciated.

Sub import_MGF_distiller_part01()
Application.ScreenUpdating = False



Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$5").AutoFilter Field:=1, Criteria1:="=*#*", _
Operator:=xlOr, Criteria2:="=*END*", Operator:=xlAnd
Selection.EntireRow.Delete Shift:=xlUp

Application.ScreenUpdating = False

Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$5").AutoFilter Field:=1, Criteria1:="=*BEGIN*", _
Operator:=xlOr, Criteria2:="=*TITLE*", Operator:=xlAnd
Selection.EntireRow.Delete Shift:=xlUp

Application.ScreenUpdating = False

Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$5").AutoFilter Field:=1, Criteria1:="=*SCANS*", _
Operator:=xlOr, Criteria2:="=*RAWSCANS*", Operator:=xlAnd
Selection.EntireRow.Delete Shift:=xlUp

Application.ScreenUpdating = False

Columns("A:A").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$5").AutoFilter Field:=1, Criteria1:="=*RTINSECONDS*", _
Operator:=xlOr, Criteria2:="=*_DISTILLER_*", Operator:=xlAnd
Selection.EntireRow.Delete Shift:=xlUp

End Sub

Bob Phillips
04-14-2012, 07:25 AM
See if this is quicker


Sub import_MGF_distiller_part01()
Dim rng As Range
Dim lastrow As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns("B").Insert
.Range("B1").Value = "tmp"
.Range("B2").Resize(lastrow - 1).Formula = "=OR(ISNUMBER(SEARCH(""#"",A2)),ISNUMBER(SEARCH(""END"",A2))," & _
"ISNUMBER(SEARCH(""BEGIN"",A2)),ISNUMBER(SEARCH(""TITLE"",A2))," & _
"ISNUMBER(SEARCH(""SCANS"",A2)),ISNUMBER(SEARCH(""ROWSCANS"",A2))," & _
"ISNUMBER(SEARCH(""RTINSECONDS"",A2)),ISNUMBER(SEARCH(""_DISTILLER_"",A2)))"
Set rng = .Range("B1").Resize(lastrow)
rng.AutoFilter
rng.AutoFilter Field:=1, Criteria1:="=TRUE"
On Error Resume Next
Set rng = rng.Offset(1, 0).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

rng.EntireRow.Delete
End If

.Columns("B").Delete
End With

Application.ScreenUpdating = True
End Sub

copyt
04-14-2012, 01:38 PM
@ xld (http://www.vbaexpress.com/forum/member.php?u=2139)

Thank you very much. Yours is much faster.

snb
04-15-2012, 08:45 AM
or

sub snb()
with application
.screenupdating=false
.calculation= xlcalculationmanual

for j=1 to 6
columns(1).replace choose(j,"*#*","END*","*BeGIN*","*TITLE*","*SCANS*","*RTINSECONDS*","*_DISTILLER_*"),"",xlpart
next
columns(1).specialcells(4).entirerow.delete

.calculation=xlcalculationautomatic
.screenupdating=true
end with
end sub

copyt
04-15-2012, 11:03 PM
@ snb (http://www.vbaexpress.com/forum/member.php?u=44644)

Thank you very much. :bow::bow: