Excel VBA - For Each Loop Alternative

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

Why are you looping through every cell? You can use Find/FindNext. — BigBen
– BigBen, Commented Feb 22, 2021 at 15:55
^^^ Can Total* be in any cell or just one column? If the later then loop just that column. Also use Union to create a unioned range so you only delete once. There are many examples on how to do that on this site. — Scott Craner
– Scott Craner, Commented Feb 22, 2021 at 15:57
Or use Range.AutoFilter if Total* is just in one column and skip looping. — BigBen
– BigBen, Commented Feb 22, 2021 at 15:58
@ScottCraner Total* can be in columns B through D currently, but I would like to future proof the code and look in all cells. — duberry
– duberry, Commented Feb 22, 2021 at 16:03
Then do the second part of my comment. set a range variable using Union. Then delete that range after the loop. — Scott Craner
– Scott Craner, Commented Feb 22, 2021 at 16:08

basodre · Accepted Answer · 2021-02-22 16:45:22Z

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

answered Feb 22, 2021 at 16:45

basodre

5,7901 gold badge18 silver badges25 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

duberry Over a year ago

Seems to work great, thank you. I just needed to change If Not inputCell.Font.Bold Then Exit Sub to If inputCell.Font.Bold Then Exit Sub.

basodre Over a year ago

@duberry That was my mistake. I misread and thought you were deleting the bold cells. Glad you were able to get it all sorted out!

Collectives™ on Stack Overflow

Excel VBA - For Each Loop Alternative

1 Answer 1

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related