How to make this code faster

[TyeReece]

I have a macro that works, but is actually slower than when I did it by hand. There are about 10000 rows that have to be looped thru and the purpose is to delete rows that meet certain conditions. Basically what it does is put the word "DEL" or "KEEP" at the end of each row and then loops thru and deletes the "DEL" rows. WHen I did by hand I would sort and then find the break and then delete a big chunk without having to loop thru. So, is there a way to improve the efficiency of the code below, or do I need to go about writing it differently.

sub
 Range("Z1").FormulaR1C1 = "Disposition"
    Range("Z2").FormulaR1C1 = _
        "=IF(RC[-12]=""X"",""DEL"",IF(RC[-4]=""Medically Complex"", ""KEEP"",IF(OR(RC[-8]=""foster home"",RC[-8]=""child caring ag"",RC[-8]=""c. licensed private child care"",RC[-8]=""e. group homes"",RC[-8]=""education"",RC[-8]=""f. residential facility"",RC[-8]=""g. children's psychiatric hosp"",RC[-8]=""independent living location"",RC[-8]=""k. independent living"",RC[-8]=""m. detention facility"",RC[-8]=""long term care facility"",RC[-8]=""medical providers"",RC[-8]=""hospitals - medical"",RC[-8]=""""),""KEEP"",""DEL"")))" & _
        ""
    Range("Z2").AutoFill Destination:=Range("z2:z" & lastRow)
    Columns("Z:Z").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    For RowtoTest = Cells(Rows.Count, 26).End(xlUp).row To 2 Step -1

    With Cells(RowtoTest, 26)
        If .Value = "DEL" _
        Then _
        Rows(RowtoTest).EntireRow.Delete
    End With

    Next RowtoTest
    Range("Z:Z").Delete Shift:=xlToLeft
    Cells.Select
    Cells.EntireColumn.AutoFit

    Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\jtreece\Desktop\058.xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True

end sub

 

[footoo]

In your formula change "DEL" to 1
After the formula is in column Z, sort by column Z to get all the 1's at the bottom.
Go to Special cells/Formulas/Numbers in column Z and delete entire row.

 

[Peter_SSs]

1. About how many rows of data do you have?

2. About what proportion of those rows do you expect to get deleted?

3. There appears to be some code missing. You are using the variable lastRow but it doesn't seem to acquire a value anywhere. Which column are you using to determine lastRow?

 

[TyeReece]

about 10000 rows and about 5500 get deleted. There is code missing. I took out for brevity. The entire code is

Sub Prepare058New()
'
' Prepare058New Macro
' Macro recorded 6/16/2008 by Tye Reece  Updated 8/14/2018
'

'
    Dim lastRow As Long
    Dim RowtoTest As Long

    lastRow = Range("A" & Rows.Count).End(xlUp).row

    ActiveSheet.Name = "058"
    Rows("1:4").Delete Shift:=xlUp
    Columns("CH:CH").Delete Shift:=xlToLeft
    Range("BI1").FormulaR1C1 = "Permanency Goal"
    Range("BJ1").FormulaR1C1 = "Permanency Goal 2"
    ActiveWorkbook.Worksheets("058").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("058").Sort.SortFields.Add Key:=Range("I2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("058").Sort
        .SetRange Range("A2:CG" & lastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    ActiveWorkbook.Save
    Range("A:A,C:D,F:G,Q:R,U:AB,AD:AE,AH:AH,AK:AM,AO:AP,AR:AV,AX:BC,BE:BH,BJ:BJ,BL:BR,BT:CG").Delete Shift:=xlToLeft
    Range("Z1").FormulaR1C1 = "Disposition"
    Range("Z2").FormulaR1C1 = _
        "=IF(RC[-12]=""X"",""DEL"",IF(RC[-4]=""Medically Complex"", ""KEEP"",IF(OR(RC[-8]=""foster home"",RC[-8]=""child caring ag"",RC[-8]=""c. licensed private child care"",RC[-8]=""e. group homes"",RC[-8]=""education"",RC[-8]=""f. residential facility"",RC[-8]=""g. children's psychiatric hosp"",RC[-8]=""independent living location"",RC[-8]=""k. independent living"",RC[-8]=""m. detention facility"",RC[-8]=""long term care facility"",RC[-8]=""medical providers"",RC[-8]=""hospitals - medical"",RC[-8]=""""),""KEEP"",""DEL"")))" & _
        ""
    Range("Z2").AutoFill Destination:=Range("z2:z" & lastRow)
    Columns("Z:Z").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    For RowtoTest = Cells(Rows.Count, 26).End(xlUp).row To 2 Step -1

    With Cells(RowtoTest, 26)
        If .Value = "DEL" _
        Then _
        Rows(RowtoTest).EntireRow.Delete
    End With

    Next RowtoTest
    Range("Z:Z").Delete Shift:=xlToLeft
    Cells.Select
    Cells.EntireColumn.AutoFit

    Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\jtreece\Desktop\058.xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
    Application.DisplayAlerts = True

End Sub

 

[footoo]

about 10000 rows and about 5500 get deleted.

Have you tried the suggestion in post #2 ?

 

[Peter_SSs]

From my testing, footoo's suggestion will shave a significant proportion off the run-time of your code, but if speed is important to you, even better can be achieved with the modification suggested below. The majority of the extra time-saving comes from turning off screen updating (always a good idea if speed is an issue), but a little more is achieved by manipulating the data & calculations in memory rather than through the worksheet formulas. These are the timing results I got.

Book1
	A	B	C
1	Code	Time (secs)	% of original time
2	OP	12.32	100.00%
3	footoo	2.41	19.56%
4	Peter	1.69	13.72%
Sheet20

To implement my suggestion into your code:

1. Right at the top of your module, above the Sub itself add (unless you have it already )

Option Compare Text

2. Add the following section immediately below your current 'Dim' statements.

Dim a As Variant, b As Variant, aRws As Variant, aCols As Variant
Dim i As Long, k As Long, nc As Long
Dim s As String
Dim bDel As Boolean

Application.ScreenUpdating = False 'This will save the majority of the time

3. Replace this whole section of your code ..

Range("Z1").FormulaR1C1 = "Disposition"
Range("Z2").FormulaR1C1 = _
    "=IF(RC[-12]=""X"",""DEL"",IF(RC[-4]=""Medically Complex"", ""KEEP"",IF(OR(RC[-8]=""foster home"",RC[-8]=""child caring ag"",RC[-8]=""c. licensed private child care"",RC[-8]=""e. group homes"",RC[-8]=""education"",RC[-8]=""f. residential facility"",RC[-8]=""g. children's psychiatric hosp"",RC[-8]=""independent living location"",RC[-8]=""k. independent living"",RC[-8]=""m. detention facility"",RC[-8]=""long term care facility"",RC[-8]=""medical providers"",RC[-8]=""hospitals - medical"",RC[-8]=""""),""KEEP"",""DEL"")))" & _
    ""
Range("Z2").AutoFill Destination:=Range("z2:z" & lastRow)
Columns("Z:Z").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

For RowtoTest = Cells(Rows.Count, 26).End(xlUp).Row To 2 Step -1

With Cells(RowtoTest, 26)
    If .Value = "DEL" _
    Then _
    Rows(RowtoTest).EntireRow.Delete
End With

Next RowtoTest
Range("Z:Z").Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.AutoFit

.. with this. I've added some comments to indicate what is happening.

nc = 26 'Col Z used to mark deletions
'Values to keep if looking at col R
s = "|foster home|child caring ag|c. licensed private child care|e. group homes|education|f. residential facility|g. children's psychiatric hosp|" _
    & "independent living location|k. independent living|m. detention facility|long term care facility|medical providers|hospitals - medical||"
aRws = Evaluate("row(2:" & lastRow & ")") 'Data rows
aCols = Array(14, 18, 22) 'Cols N, R, V after data rearrangement
a = Application.Index(Cells, aRws, aCols) 'Data to check for DEL or KEEP - read into memory
ReDim b(1 To UBound(a), 1 To 1) 'To record rows to delete
'Now replicate the col Z formula results & use the b array to record deletion rows
For i = 1 To UBound(a)
  Select Case True
    Case a(i, 1) = "X": bDel = True
    Case a(i, 3) = "Medically complex"
    Case InStr(1, s, "|" & a(i, 2) & "|") = 0: bDel = True
  End Select
  If bDel Then
    b(i, 1) = 1
    k = k + 1
    bDel = False
  End If
Next i
'If there are rows to delete, write the b array to the sheet, sort & delete one single block of rows per footoo's suggestion
If k > 0 Then
  With Range("A2").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    .Resize(k).EntireRow.Delete
  End With
End If
ActiveSheet.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True

 

[TyeReece]

I haven't tried footoo's suggestion yet but will. I am still a novice at this but am finally catching on. Thanks to the both of you!

 

[Peter_SSs]

I haven't tried footoo's suggestion yet but will. I am still a novice at this but am finally catching on. Thanks to the both of you!

You're welcome. (Hopefully you will try the other suggestion too. )

 

[TyeReece]

Just a thank you to both of you. I used both suggestions and now works great! Thanks!

 

[Peter_SSs]

Just a thank you to both of you. I used both suggestions and now works great! Thanks!

You're welcome. Glad you have something suitable.