3
\$\begingroup\$

I'm looking to optimize my for loop to search faster. I've turned off ScreenUpdating, EnableEvents, Calculation, and DisplayStatusBar to speed it up a litte. I have about 10,000 rows to search for in the FAR tab. It works by reading the FAR tab rows and if it matches the master account list ("Account_Range") located in the Input tab, it won't delete the row. It will then update the rows (not shown above). I ran this and it took exactly an hour to run.

Sub DeleteRowsWithArray()

Dim dontDelete() As Variant
Dim actRange As range
Set actRange = Sheets("Input").range("Account_Range")

dontDelete = actRange

Dim i As Long, j As Long

Dim isThere As Boolean

Sheets("FAR").Select

For i = Cells(Rows.Count, "B").End(xlUp).Row To 3 Step -1
    For j = LBound(dontDelete) To UBound(dontDelete)
        If StrComp(range("B" & i), dontDelete(j, 1), vbTextCompare) = 0 Then
            isThere = True
        End If
    Next j
    If Not isThere Then
        range("B" & i).Delete shift:=xlUp
    End If
        isThere = False
Next i

End Sub
\$\endgroup\$
  • \$\begingroup\$ I suggest building a Dictionary to hold the Range("Account_Range"), then you wouldn't have to loop to find a match, just use .Exists. I suspect the longest process is deleting rows and moving up all the remaining rows. \$\endgroup\$ – PeterT Jun 9 '17 at 13:37
1
\$\begingroup\$

In your code there are several slow items:

1.

  • StrComp(Range("B" & i), dontDelete(j, 1), vbTextCompare) = 0
  • I would use Range("B" & i).Value2 = dontDelete(j, 1).Value2

2.

  • Like PeterT suggested deleting rows is quite slow, specially when you do it one at the time
  • I would hide the rows to keep, and at the end delete all visible rows in one operation

3.

  • Another significant performance issue is caused by interacting with the sheet
  • You could copy both ranges into 2 separate variants and loop them the same way as ranges

Bellow I'm providing a different approach:

  • create a new column with a formula that will find all matches from Account_Range
  • use AutoFilter to hide the rows you want to keep
  • delete all visible rows in one operation

Option Explicit

Public Sub DeleteRowsFilter()
  Const FAR_ROW1 As Long = 3

  Dim lrInput As Long, lrFAR As Long, lcFAR As Long, lastCell As Range
  Dim srcRng As String, fCell As Range, formulaRng As Range, t As Double

  FastWB
  t = Timer

  With ThisWorkbook.Worksheets("FAR")
    Set lastCell = GetMaxCell(.UsedRange)
    lrFAR = lastCell.Row
    lcFAR = lastCell.Column

    'create a new column showing if row should be deleted (value = 0) or not (value > 0)
    Set fCell = .Cells(FAR_ROW1, lcFAR + 1)
    fCell.Formula = "=IFERROR(MATCH(B" & FAR_ROW1 & ",Account_Range,0),0)"

    'fill down the formula to last row
    Set formulaRng = .Range(fCell, .Cells(lrFAR, lcFAR + 1))
    fCell.AutoFill Destination:=formulaRng: .Calculate

    'hide the rows to keep
    formulaRng.AutoFilter Field:=1, Criteria1:="=0"

    'delete visible rows (not matching values in Account_Range)
    fCell.Offset(1).Resize(lrFAR - FAR_ROW1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Columns(lcFAR + 1).EntireColumn.Delete 'delet last column (temp formula)
  End With

  Debug.Print "Duration:" & vbTab & Format(Timer - t, "#,##0.0000") & " sec" & vbCrLf
  FastWB False
End Sub

In my test file I only used 2 columns on each sheet, both with 10,000 rows
This version deleted more than 6,000 rows

Total Duration: 1.9338 sec


I also used 2 helper functions

Turn off visual elements:

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
End Sub

Determine the last row and column:

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.