Excel speeding up a for loop

Question

I have the current code and it works as i need it to. The problem is it takes quite a while to run through due to the for loop. The variable x ranges from 300 to about 8000. I am attempting to add in code to hide unimportant dates based on when a client pays. I need to include all dates rather than just generate a weekly/fortnightly/monthly calendar as other events occur on those dates. I will be adding a hide/unhide code for the other event dates as well but at the moment im wondering if it is possible to speed up this code.

Sub Client_Payments()
    Application.ScreenUpdating = False
    Dim first As Integer
    Dim x As Integer
    Dim n As Integer
    Dim ws1 As Worksheet
    Set ws1 = Sheets("Payment_Summary")
    first = Application.Match(Range("Next_Payment").Value2, ws1.Range("A:A"), 0)
    x = ThisWorkbook.Sheets("Payment_Summary").Range("Duration").Value2 + 7
    ThisWorkbook.Sheets("Payment_Summary").Range(Cells(7, 1), Cells(x, 1)).EntireRow.Hidden = True

    If ThisWorkbook.Sheets("Client_Details").Range("Freq").Value = "Weekly" Then
        For n = 0 To x / 7
            ws1.Cells(first + (n * 7), 2).EntireRow.Hidden = False
        Next
    End If

    If ThisWorkbook.Sheets("Client_Details").Range("freq").Value = "Fortnightly" Then
        For n = 0 To x / 14
            ws1.Cells(first + (n * 14), 2).EntireRow.Hidden = False
        Next
    End If

    If ThisWorkbook.Sheets("Client_Details").Range("freq").Value = "Monthly" Then
        For n = 0 To x / 30
            If Day(ws1.Cells(n + first, 1).Value) = Day(ThisWorkbook.Sheets("Client_Details").Range("Next_payment").Value) Then
                ws1.Cells(n + first, 1).EntireRow.Hidden = False
            End If
        Next
    End If

End Sub

Answer 1

In an effort to look for ways to speed it up I have re-written your code and commented it. This is what I came up with.

Private Sub TestOpen()

    Dim WsSum As Worksheet                      ' give a meaningful name
    Dim WsClient As Worksheet
    Dim Tmp As Variant
    Dim First As Long                           ' rows and columns are generally Long
    Dim x As Long
    Dim n As Long

    Set WsSum = ThisWorkbook.Sheets("Payment_Summary")
    Set WsClient = ThisWorkbook.Sheets("Client_Details")
    Application.ScreenUpdating = False

    ' For the next line no worksheet is specified.
    ' Therefore the ActiveSheet will be referenced.
    ' Better specify the sheet.
    Tmp = Range("Next_Payment").Value2          ' this must be a single cell

    ' Once you (correctly!) assign a sheet to a variable
    ' use the variable to refer to it in the code that follows.
    With WsSum
        On Error Resume Next
        If Err Then
            MsgBox "The match criterium """ & Tmp & """ wasn't found.", _
                   vbCritical, "Data error"
        Else
            First = Application.Match(Tmp, .Columns("A"), 0)
            x = .Range("Duration").Value2 + 7
            .Range(Rows(7), Rows(x)).EntireRow.Hidden = True

            Select Case WsClient.Range("Freq").Value
                Case "Weekly"
                    For n = 0 To Int(x / 7)
                        .Rows(First + (n * 7)).EntireRow.Hidden = False
                    Next
                Case "Fortnightly"
                    For n = 0 To Int(x / 14)
                        .Rows(First + (n * 14)).EntireRow.Hidden = False
                    Next
                Case "Monthly"
                    For n = 0 To Int(x / 30)
                        Tmp = WsClient.Range("Next_payment").Value
                        ' which value should this be if Tmp is not a date
                        ' from which the Day can be extracted? (I assign 1)
                        Tmp = IIf(IsDate(Tmp), Day(Tmp), 1)
                        If Day(.Cells(n + First, 1).Value) = Tmp Then
                            .Cells(n + First, 1).EntireRow.Hidden = False
                        End If
                    Next
            End If
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Don't hold your breath though, my version won't run faster than yours. In fact, it may not run at all. In that case please bear with me and correct the errors the debugger will show you. I couldn't test run it and there may be some typos.

The aim of this exercise was to understand the code. This is what I understood. You look at the Freq range and take action depending upon its value which describes a period like "weekly, "monthly", "fortnightly". Since the cell can hold only one value at a time the Select Case statement is more suitable than repeated Ifs.

In each case you look up the value "x" which I understand to be in the region of 8000. I have some doubt as to the accuracy of your definition of the rows you wish to hide because x + 7 looks like it is designed for weekly lists. When you divide by 30 the result may not be what you want. I would use Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row to determine the last row (=x) and then loop with For n = First To x Step 7 (or 14 or 30) to define every 7th, 14th or 30th row. But that won't be faster than what you got, either.

Asked how I would make it faster, I must say that I wouldn't use this kind of code at all. I would look for a way to apply a filter. If a better way can't be found, create a helper column and write code to enter an x in the rows you want to show. Then filter on "x".

To quickly assign an "x" to 8000 rows use this kind of construct.

Dim Arr As Variant
Dim Rng As Range
Dim i As Long
Redim Arr(1 to 8000)     ' use x
For i = 1 to Ubound(Arr) Step 7
    Arr(i) = "x"
Next i
Set Rng = Ws.Cells(First, Helper).Resize(Ubound(Arr),1)
Rng = Application.Transpose(Arr)

You could use much of your existing code to write this procedure, and I guarantee it would be faster. You might even add code to apply the filter.

Answer 2

There are ways of speeding up your code - most have been mentioned in the comments. The two main ones are to read your cell date values into an array, and to populate a single Range of rows to be unhidden.

I'm not entirely convinced by your coding logic though. There'll be problems if someone accidentally deletes one or more date rows, and the increment of dates looks a little shaky (e.g. what happens on a leap year?). I wonder if you'd be better iterating the row of dates and, if you find a match, store the row and then increment the date by the specified interval.

Without seeing your worksheet structures (and your range name definitions), it's difficult to be precise, but code might look a little like below. I haven't checked the speed against your current code, but I'd say there's a fair to middling chance it will be quicker:

Const FIRST_ROW As Long = 7 'first row of dates on Payment_Summary sheet.

Dim summaryWs As Worksheet
Dim summary, interval As Variant
Dim payDate As Long, duration As Long
Dim nextDate As Long, n As Long, i As Long, r As Long, p As Long
Dim frq As String
Dim rng As Range, unhideRng As Range
Dim showProgress As Boolean

'Display progress.
showProgress = True 'set to false if you don't want progress displayed.
Application.StatusBar = "Reading dates..."
DoEvents

'Acquire the payment parameters.
payDate = #3/3/2020# '-> just an example, read your own value.
duration = 8000 '-> just an example, read your own value.
frq = "Monthly" '-> just an example, read your own value.

'Read date values into an array.
Set summaryWs = ThisWorkbook.Worksheets("Payment_Summary")
With summaryWs
    Application.ScreenUpdating = False
    'Unhide the rows to read the values.
    .Rows.EntireRow.Hidden = False
    'Read values
    summary = .Range( _
                .Cells(FIRST_ROW, "A"), _
                .Cells(duration + FIRST_ROW - 1, "A")) _
            .Value2
    'Re-hide the rows.
    .Rows(FIRST_ROW).Resize(duration).EntireRow.Hidden = True
    Application.ScreenUpdating = True
End With

'Set the DateAdd parameters, based on frequency.
Select Case frq
    Case "Weekly": interval = Array("ww", 1)
    Case "Fortnightly": interval = Array("d", 14)
    Case "Monthly": interval = Array("m", 1)
End Select

p = 0 'progress indicator.
nextDate = payDate 'initialise target date.

'Iterate the dates.
For i = 1 To duration
    'Show progress.
    If showProgress Then
        If Int(i / duration * 100) > p Then
            p = Int(i / duration * 100)
            Application.StatusBar = p & "% complete"
            DoEvents
        End If
    End If

    'Check for a skipped date.
    'Logic:
    '   The current summary date should never be greater
    '   than the next date we're looking for.
    '   If it is, a day is missing from the summary sheet,
    '   so increment the next date to be more than the
    '   current summary date.
    Do While summary(i, 1) > nextDate
        nextDate = DateAdd(interval(0), interval(1), nextDate)
    Loop

    'Check for a matching date.
    If summary(i, 1) = nextDate Then
        'Set the row.
        r = i + FIRST_ROW - 1
        Set rng = summaryWs.Rows(r)
        'Add row to unhide range.
        If unhideRng Is Nothing Then
            Set unhideRng = rng
        Else
            Set unhideRng = Union(unhideRng, rng)
        End If
        'Increment the date.
        nextDate = DateAdd(interval(0), interval(1), nextDate)
    End If
Next

'Unhide the target rows
If Not unhideRng Is Nothing Then
    unhideRng.EntireRow.Hidden = False
End If

'Clear the progress bar.
If showProgress Then
    Application.StatusBar = False
End If