Increase macro speed

[All2Cheesy]

Hi all,

I've got a macro which deletes rows which do not have a cell equal to "kilogram", while also inserting a blank row after each instance of "99999". To do this I am using multiple loops, and as such running this macro takes quite a bit of time. Is there any way I can clean up my code to have my macro run a bit quicker? Thanks!

Sub DELROWs()
 Dim couNter As Long
 Dim RowCount As Long
 
 'Disable additional features
With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayAlerts = False
End With

 RowCount = Range("B65536").End(xlUp).Row
 couNter = 1
 Do Until couNter > RowCount
 If Range("F" & couNter).Value <> "Kilogram" Then
 Range("F" & couNter).EntireRow.Delete
 RowCount = RowCount - 1
 couNter = couNter - 1
 End If
 couNter = couNter + 1
 Loop

 RowCount = Range("B65536").End(xlUp).Row
 couNter = 1
 Do Until couNter > RowCount
 If Range("D" & couNter).Value = 99999 Then
 Range("D" & couNter + 1).EntireRow.Insert
 RowCount = RowCount + 1
 couNter = couNter + 1
 End If
 couNter = couNter + 1
 Loop
 Application.ScreenUpdating = True
 
 'Disable additional features
With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
End With
 
 End Sub

 

[Rick Rothstein]

Does Column D contain constants or formulas?

Does Column F contain constants or formulas?

Is there formulas in any of the other columns?

 

[Michael M]

you need to run your code from the last row UP.....not from the first row down !
Don't have Excel at the moement, but try...

Sub DELROWs()
 Dim couNter As Long, RowCount As Long
With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
        .DisplayAlerts = False
End With
 RowCount = Cells(Rows.Count, "B").End(xlUp).Row
For couNter = RowCount To 1 Step -1
    If Range("F" & couNter).Value <> "Kilogram" Then
        Rows(couNter).Delete
    End If
Next couNter
 RowCount = Cells(Rows.Count, "B").End(xlUp).Row
For couNter = RowCount To 1 Step -1
    If Range("D" & couNter).Value = 99999 Then
        Rows(couNter + 1).EntireRow.Insert
    End If
Next couNter
With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
End With
 
 End Sub

 

[All2Cheesy]

There are formulas in all columns. All of the formulas simply reference a cell on another sheet.

 

[All2Cheesy]

Okay thanks. I'll definitely keep that in mind.

There was no notable difference in speed using your formula unfortunately.

 

[Rick Rothstein]

There was no notable difference in speed using your formula unfortunately.

See if this macro is any faster...
[table="width: 500"]
[tr]
[td]

Sub DeleteAndInsertRows()
  Dim X As Long, LastRow As Long, UnusedColumn As Long, Cell As Range
  UnusedColumn = Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
  LastRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Cells(1, UnusedColumn).Resize(LastRow) = Evaluate("IF(F1:F" & LastRow & "<>""Kilogram"",""X"","""")")
  On Error GoTo AllKilograms
  Columns(UnusedColumn).SpecialCells(xlConstants).EntireRow.Delete
  LastRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
InsertAt99999:
  Cells(2, UnusedColumn).Resize(LastRow) = Evaluate("IF(D1:D" & LastRow & "=99999,""X"","""")")
  X = Columns(UnusedColumn).Find("X", , xlValues, , , xlPrevious).Row
  Do
    Rows(X).Insert
    X = Columns(UnusedColumn).Find("X", Cells(X, UnusedColumn), xlValues, , , xlPrevious).Row
  Loop While X < LastRow
  Columns(UnusedColumn).Delete
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Exit Sub
AllKilograms:
  Resume InsertAt99999
End Sub

[/td]
[/tr]
[/table]

 

[All2Cheesy]

That's worked a treat! Thank you very much.