Excel VBA - For Each Loop Alternative - excel

Question

I have a For Each Loop that looks for cells that contain a string with a wildcard and if that string is not bold. If those conditions are met then that cell's row is deleted. I believe the For Each Loop is inefficient, and even with only around 200 rows the code takes a few seconds to run. Is there a more efficient way to achieve these results?
Dim Cell As Range
Dim sheetRange As Range
Set sheetRange = ActiveSheet.UsedRange
For Each Cell In sheetRange
Set Cell = sheetRange.Find(What:="Total*", lookat:=xlPart)
If Not Cell Is Nothing Then
If Cell.Font.Bold = False Then
Cell.EntireRow.Delete
End If
End If
Next Cell

Answer 1

Please take a look at the code below and see if you can adapt it to your specific use case. The DeleteTotalRows subroutine uses the built-in .Find method to jump specifically to cells that include the value 'Total'. It passes each of these cells to the MergeDeleteRange subroutine. This sub will build a range to delete, which contains all rows with the Total word and bold font.
Report back if you run into issues.
Option Explicit
Sub DeleteTotalRows()
Dim fnd As Range
Dim rngToDelete As Range
Dim firstFnd As Range
Dim sht As Worksheet
'Update this
Set sht = Worksheets("Sheet2")
With sht
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart)
If fnd Is Nothing Then Exit Sub
Set firstFnd = fnd
Do
MergeDeleteRange rngToDelete, fnd
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart, after:=fnd)
Loop While fnd.Address <> firstFnd.Address
End With
If rngToDelete Is Nothing Then Exit Sub
rngToDelete.Delete
End Sub
Private Sub MergeDeleteRange(ByRef outputRng As Range, ByRef inputCell As Range)
'Not deleting if the cell isn't bold
If Not inputCell.Font.Bold Then Exit Sub
'Create output range if it's still empty
If outputRng Is Nothing Then Set outputRng = inputCell.EntireRow
'Since you are testing multiple columns, confirm that the
'row isn't already in the output range
If Not Intersect(inputCell, outputRng) Is Nothing Then
Exit Sub
End If
Set outputRng = Union(outputRng, inputCell.EntireRow)
End Sub