4
\$\begingroup\$

I have created several macros that delete rows based on cell values. I run it 5 times for different data, but think there should be a way to combine them and speed up the macro. Currently, it is running a little slow.

It is pulling a date from another worksheet and if it doesn't match, removing the line. I am basically running the same macro over and over, just changing the values slightly.

I am just changing the value in column E (120 in this example, but could be 30, 60, 90, etc) and seeing if it matches the date on another worksheet. The cell on the other worksheet changes depending on E value If 30, use date A1 If 60, use date in A2 etc.

Here is one of the five macros I have:

Sub Remove_FutureRenewals_120()
    Dim Firstrow As Long
    Dim LastRow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

Firstrow = ThisWorkbook.Worksheets(2).UsedRange.Cells(1).Row
LastRow = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "A").End(xlUp).Row

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    '.ScreenUpdating = False
End With

With ActiveSheet
    For Lrow = LastRow To Firstrow Step -1
        With .Cells(Lrow, "E")
            If Not IsError(.Value) Then
                If .Value = "120" _
                    And Format(.Offset(0, -1).Value, "YYYYMMDD") <> Format(ThisWorkbook.Worksheets("Date Calc").Cells(5, "A").Value, "YYYYMMDD") _
                    Then .EntireRow.Delete
            End If
        End With

    Next Lrow

End With

End Sub
\$\endgroup\$
1
\$\begingroup\$

An interesting learning experience.

Well done for doing the deletion in a backwards loop. Also, well done for declaring all variables.

As you have implied, there is room for some improvement. What I suggest below may not increase speed, but should at least help with maintainability and readability.

Three different ways of accessing a sheet

You are using three different ways of accessing a sheet: index, ActiveSheet and name. Each has their uses and are valid, but mixing methods in a single routine makes it a little more confusing to read.

You haven't identified how the routine is called, and this makes a difference on the applicability of ActiveSheet. How can you guarantee that the active sheet is the one that you want to clean up?

You also reference your FirstRow and LastRow from a fixed sheet, not your ActiveSheet - how can you be sure that they are correct?

Speed up routine

You set your calculation mode and attempted to turn off screen updating. But you don't turn them back again at the end of the routine.

Also consider setting .EnableEvents = False so that you do not fire events every time you delete a row.

Tweaks

Consider using a Select Case to identify a valid row. I have an example in the code below.

Consider creating a Union for each row that you find and want to delete. Then use this union to delete all the rows at once, instead of one at a time.

Put your date value into a variable, rather than accessing the cell each time in the loop. This will save some time and accessing the Excel cells/ranges is relatively expensive.

Perhaps this code?

Sub Remove_FutureRenewals()
    Dim Firstrow As Long
    Dim LastRow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim SelectedSheet as Worksheet
    Dim BaseDate as String

    Set SelectedSheet = ActiveSheet ' addresses any change to ActiveSheet while routine is running. 
    BaseDate = Format(ThisWorkbook.Worksheets("Date Calc").Cells(5, "A").Value, "YYYYMMDD")

    Firstrow = SelectedSheet.UsedRange.Cells(1).Row 
    LastRow = SelectedSheet.Cells(ThisWorkbook.Worksheets(2).Rows.Count, "A").End(xlUp).Row

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With SelectedSheet 
        For Lrow = LastRow To Firstrow Step -1
            Select Case .Cells(Lrow, "E").Value ' always be explicit.
                Case "120", "90", "60" 'etc
                    'If Format(.Cells(Lrow, "E").Offset(0, -1).Value, "YYYYMMDD") <> BaseDate Then
                    If Format(.Cells(Lrow, "D").Value, "YYYYMMDD") <> BaseDate Then
                        .EntireRow.Delete
                    End If ' Better practice to use a full If-The-Endif block rather than a single line
            End Select
        Next Lrow
    End With
    With Application
        .Calculation = CalcMode 
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

This code still has a lot of "magic numbers" in it, but should give you some ideas on where to go next.

\$\endgroup\$
1
\$\begingroup\$

Firstrow and LastRow

Firstrow and LastRow refer to cells on ThisWorkbook.Worksheets(2) but are used to iterate over the cells of the ActiveSheet. I'm guessing that ThisWorkbook.Worksheets(2) is the original data that is being copied to a new worksheet for processing. In any case, it would be better to have them refer to the same worksheet. After all you are reducing the number of rows 5 times.

Firstrow = ThisWorkbook.Worksheets(2).UsedRange.Cells(1).Row
LastRow = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "A").End(xlUp).Row

With ActiveSheet
    For Lrow = LastRow To Firstrow Step -1

Repeat Code

There are 5 procedures that basically do the same thing. Extracting the repeated code into its own subroutine and passing in the variable information will make the code easier to read, modify and debug.

Sub Remove_FutureRenewals(ws As Worksheet, EValue As Variant, CalcDate As Date)

Note: The eValue parameter is meant to tests the values in Column e. It is typed as Long because all the values (30, 60, 90, 120) are integer values. If this is the case then .Value = "120" should be .Value = 120. Using a string for a number should be avoided.

Keep Formatting

If you want to preserve formatting then it would be best to Union() all the rows to be deleted and delete them all at once.

Sub Remove_FutureRenewals(ws As Worksheet, EValue As Variant, CalcDate As Date)
    Dim cell As Range, target As Range

    CalcDate = DateValue(CalcDate)

    With ws
        For Each cell In .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
            With cell
                If Not IsError(.Value) And IsDate(.Offset(0, -1).Value) Then
                    If .Value = EValue And DateValue(.Offset(0, -1).Value) <> CalcDate Then
                        If target Is Nothing Then
                            Set target = .EntireRow
                        Else
                            Set target = Union(target, .EntireRow)
                        End If
                    End If
                End If
            End With
        Next
    End With

    If Not target Is Nothing Then
        Dim CalcMode As XlCalculation
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False

            target.Delete

            .Calculation = CalcMode
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

Values Only

When working with values it is much faster to use arrays then it is to delete multiple rows.

Here is the pattern that I use: - Define a target Range. In this case I just used the UsedRange - Load the target.Value into a variant called data. data = target.Value - Make a second array named results the same size as the data array - Iterate over the data array adding any rows to be kept to the results array - Write the results over the original target range

Sub Remove_FutureRenewals2(ws As Worksheet, EValue As Variant, CalcDate As Date)
    CalcDate = DateValue(CalcDate)
    Dim data As Variant, results As Variant
    data = ws.UsedRange.Value

    ReDim results(1 To UBound(data), 1 To UBound(data, 2))

    Dim r As Long, c As Long, resultsRow As Long

    For r = 1 To UBound(data)
        If data(r, 5) = EValue And DateValue(data(r, 4)) = CalcDate Then
            resultsRow = resultsRow + 1

            For c = 1 To UBound(data, 2)
                results(resultsRow, c) = data(r, c)
            Next

        End If

    Next

    Application.ScreenUpdating = False
    ws.UsedRange.Value = results

End Sub
\$\endgroup\$
0
\$\begingroup\$

I would not run the Delete until after the end of your procedure. Create a range using Union and then run the delete at the end.

Dim DeleteRNG As Range

'Do this First so you don't have to keep if-statements checking throughout the loop.
Set DeleteRNG = Cells(Rows.Count, 1)


'Then Run your loops and check

    If .Value = "120" _
                    And Format(.Offset(0, -1).Value, "YYYYMMDD") <> Format(ThisWorkbook.Worksheets("Date Calc").Cells(5, "A").Value, "YYYYMMDD") _
                    Then
            Set DeleteRNG = Union(.EntireRow, DeleteRNG)
    End If


'then after all looops

    DeleteRNG.EntireRow.Delete
\$\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.