VBA code which creates a daily report, based on data gathered in Worksheets in an Excel Workbook

Question

I'm looking for some enlightening, since I'm still learning to code in VBA. I'm running code to create a daily report. It has to compare dates and check certain values in those dates and based on that I get my info. The info is gathered from three worksheets that are on the same workbook. It's working since it does what I wanted it to do, and at the start of the month it was working "fast". But now since my data is getting bigger, it also became slow and I think it's because I didn't optimize it and I'm running it on a desktop with an Intel Core i7-7700.

I will post a fragment of the code where I notice it's getting slow and the start of the code for variables.

Sub gen_informe()

Dim wsrgcmes As Worksheet
Dim wshtte As Worksheet
Dim wsstats As Worksheet
Dim rdate As Range
Dim celdate As Range
Dim idtask As Range
Dim rtask As Range
Dim idcaso As Range
Dim rcaso As Range
Dim rstats As Range
Dim idstats As Range
Dim x As Long
Dim i As Double
Dim fregistro As Double
Dim coninc As Integer
Dim conser As Integer
Dim fcierre As Double
Dim ansin As String
Dim ansout As String

Set wsrgcmes = ThisWorkbook.Worksheets("ResumenGeneralCasosMES")
Set wshtte = ThisWorkbook.Worksheets("HistoricoTareas")
Set wsstats = ThisWorkbook.Worksheets("SolucionadosTATS")

With wsrgcmes
    Set rdate = .Range("W2", .Cells(.Rows.count, .Columns("W:W").Column).End(xlUp))
    Set rcaso = .Range("B2", .Cells(.Rows.count, .Columns("B:B").Column).End(xlUp))
End With

With wshtte
    Set rtask = .Range("B2", .Cells(.Rows.count, .Columns("B:B").Column).End(xlUp))
End With

With wsstats
    Set rstats = .Range("E2", .Cells(.Rows.count, .Columns("E:E").Column).End(xlUp))
End With

Sheets("Informe").Range("B4").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    For Each celdate In rdate
        fregistro = CDbl(Int(celdate.Value))
        If fregistro = i Then
            Select Case celdate.Offset(0, -19).Value
                Case "INCIDENTE"
                    coninc = coninc + 1
                Case "LLAMADA DE SERVICIO"
                    conser = conser + 1
            End Select
        End If
    Next celdate
    ActiveCell.Offset(0, x).Value = coninc
    ActiveCell.Offset(1, x) = conser
    x = x + 1
    coninc = 0
    conser = 0
Next i

coninc = 0
conser = 0
i = 0
x = 0

Sheets("Informe").Range("B12").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    For Each celdate In rdate
        fregistro = CDbl(Int(celdate.Value))
        fcierre = CDbl(Int(celdate.Offset(0, 2).Value))
        If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then
            Select Case celdate.Offset(0, -19).Value
                Case "INCIDENTE"
                    coninc = coninc + 1
                Case "LLAMADA DE SERVICIO"
                    conser = conser + 1
            End Select
        End If
    Next celdate
    ActiveCell.Offset(0, x).Value = coninc
    ActiveCell.Offset(1, x) = conser
    x = x + 1
    coninc = 0
    conser = 0
Next i

coninc = 0
conser = 0
i = 0
x = 0

Sheets("Informe").Range("B19").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    For Each celdate In rdate
        fregistro = CDbl(Int(celdate.Value))
        fcierre = CDbl(Int(celdate.Offset(0, 2).Value))
        If fregistro < CDbl(DateSerial(Year(Date), Month(Date), 1)) And fcierre = i Then
            Select Case celdate.Offset(0, -19).Value
                Case "INCIDENTE"
                    coninc = coninc + 1
                Case "LLAMADA DE SERVICIO"
                    conser = conser + 1
            End Select
        End If
    Next celdate
    ActiveCell.Offset(0, x).Value = coninc
    ActiveCell.Offset(1, x) = conser
    x = x + 1
    coninc = 0
    conser = 0
Next i

contask = 0
i = 0
x = 0

Sheets("Informe").Range("B27").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idtask In rtask
        With Application
            Set idcaso = .Index(rcaso, .Match(idtask.Offset(0, -1).Value, rcaso, 0))
        End With
        fregistro = CDbl(Int(idcaso.Offset(0, 21).Value))
        If fregistro = i Then
            contask = contask + 1
        End If
    Next idtask
    ActiveCell.Offset(0, x).Value = contask
    x = x + 1
    contask = 0
Next i

contask = 0
i = 0
x = 0

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idtask In rtask
        With Application
            Set idcaso = .Index(rcaso, .Match(idtask.Offset(0, -1).Value, rcaso, 0))
        End With
        fregistro = CDbl(Int(idcaso.Offset(0, 21).Value))
        fcierre = CDbl(Int(idtask.Offset(0, 7).Value))
        If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then
            contask = contask + 1
        End If
    Next idtask
    ActiveCell.Offset(1, x).Value = contask
    x = x + 1
    contask = 0
Next i

contask = 0
i = 0
x = 0

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idtask In rtask
        With Application
            Set idcaso = .Index(rcaso, .Match(idtask.Offset(0, -1).Value, rcaso, 0))
        End With
        fregistro = CDbl(Int(idcaso.Offset(0, 21).Value))
        fcierre = CDbl(Int(idtask.Offset(0, 7).Value))
        If fregistro < CDbl(DateSerial(Year(Date), Month(Date), 1)) And fcierre = i Then
            contask = contask + 1
        End If
    Next idtask
    ActiveCell.Offset(2, x).Value = contask
    x = x + 1
    contask = 0
Next i

From here on, it starts getting slower, these last two for-loops are iterating a lot it seems. I used similar for-loops along the code, maybe poor optimization on my part.

i = 0
x = 0
ansin = 0
ansout = 0

Sheets("Informe").Range("B42").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idstats In rstats
        With Application
            Set idcaso = .Index(rcaso, .Match(idstats.Value, rcaso, 0))
        End With
        fcierre = CDbl(Int(idcaso.Offset(0, 23).Value))
        If fcierre = i And idstats.Offset(0, -1).Value = "Incidente" Then
            Select Case idstats.Offset(0, 20).Value
                Case "S"
                    ansin = ansin + 1
                Case "N"
                    ansout = ansout + 1
            End Select
        End If
    Next idstats
    ActiveCell.Offset(0, x).Value = ansin
    ActiveCell.Offset(1, x) = ansout
    x = x + 1
    ansin = 0
    ansout = 0
Next i

i = 0
x = 0
ansin = 0
ansout = 0

Sheets("Informe").Range("B49").Select

For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idstats In rstats
        With Application
            Set idcaso = .Index(rcaso, .Match(idstats.Value, rcaso, 0))
        End With
        fcierre = CDbl(Int(idcaso.Offset(0, 23).Value))
        If fcierre = i And idstats.Offset(0, -1).Value = "Requerimiento" Then
            Select Case idstats.Offset(0, 20).Value
                Case "S"
                    ansin = ansin + 1
                Case "N"
                    ansout = ansout + 1
            End Select
        End If
    Next idstats
    ActiveCell.Offset(0, x).Value = ansin
    ActiveCell.Offset(1, x) = ansout
    x = x + 1
    ansin = 0
    ansout = 0
Next i


End Sub

Answer 1

I think your idea here with your code is a good one. Your execution, though, as you see, is not optimized. But that's okay!

Refactoring

The first concept I'd like to bring up is refactoring. When you do something more than once it's usually a lot cleaner to write it once and use it several times. How? Create another function or sub. You have 8 For with some loops doing, I think, the same basic thing. As far as I can tell, there are basically three loops. I'll name them -

Select Loop

Select Case celdate.Offset(0, -19).Value

fregistro loop

If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then 'this line changes in 3

fcierre loop

If fcierre = i And idstats.Offset(0, -1).Value = "Incidente" Then 'this line changes in 2

I hope that's clear. If we look at the fregistro loop -

Sheets("Informe").Range("B27").Select 'this line changes
For i = CDbl(DateSerial(Year(Date), Month(Date), 1)) To CDbl(Date)
    On Error Resume Next
    For Each idtask In rtask
        With Application
            Set idcaso = .Index(rcaso, .Match(idtask.Offset(0, -1).Value, rcaso, 0)) 'optional
        End With
        fregistro = CDbl(Int(idcaso.Offset(0, 21).Value))
        fcierre = CDbl(Int(idtask.Offset(0, 7).Value)) 'this changes
        If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then 'this line changes in 3
            contask = contask + 1
        End If
    Next idtask
    ActiveCell.Offset(1, x).Value = contask 'this line changes in 3
    x = x + 1
    contask = 0
Next i

contask = 0
i = 0
x = 0

A few things change loop to loop -

fcierre = CDbl(Int(idtask.Offset(0, 7).Value)) 'this happens in 2 of 3 
If fregistro < CDbl(DateSerial(Year(Date), Month(Date), 1)) And fcierre = i Then '>, <, =
ActiveCell.Offset(2, x).Value = contask '0, 1, 2

As you see, the basic thing that's changing is your if condition and your target cell. Those would be your parameters because they are variable. Let's say nothing else changes for now, you would use this:

Private Sub fregistro(ByVal testCondition As Long, ByVal targetRow As Long, ByVal targetDate As Date, Optional ByVal fcierreTest As Long = 0)
    Sheets("Informe").Range("B27").Select
    For i = CDbl(DateSerial(Year(targetDate), Month(targetDate), 1)) To CDbl(targetDate)
        On Error Resume Next
        For Each idtask In rtask
            With Application
                Set idcaso = .Index(rcaso, .Match(idtask.Offset(0, -1).Value, rcaso, 0))
            End With
            fregistro = CDbl(Int(idcaso.Offset(0, 21).Value))
            If Not fcierreTest = 0 Then
                fcierre = CDbl(Int(idtask.Offset(0, 7).Value))
            End If
            
            Select Case testCondition
                Case 0
                If fregistro = i Then
                    contask = contask + 1
                End If
                Case 1
                If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then
                    contask = contask + 1
                End If
                Case 2
                If fregistro < CDbl(DateSerial(Year(Date), Month(Date), 1)) And fcierre = i Then
                    contask = contask + 1
                End If
                Case Else
            End Select
            
        Next idtask
        ActiveCell.Offset(targetRow, x).Value = contask
        x = x + 1
        contask = 0
    Next i
End Sub

And then you would just do this from the main sub -

fregistro 1, 0, Date
fregistro 2, 1, Date, True
fregistro 2, 2, Date, True

Right? You could do that for all three loops and your code would be more clear. That's the first concept.

---

Optimizing

So refactoring is a big part of optimization, but the refactoring isn't going to fix your bottleneck. Let's look at the fregistro sub again. Your basic procedure is

For i = CDbl(DateSerial(Year(targetDate), Month(targetDate), 1)) To CDbl(targetDate)
    For Each idtask In rtask
        With Application
        End With
        If isFcierreTest Then
        End If
        Select Case testCondition
        End Select
     Next
    ActiveCell.Offset(targetRow, x).Value = contask
    x = x + 1
    contask = 0
Next i

So you see you have a For Each loop inside a For loop. For every value. That's slow, let me tell you. You're also needing to reset x and contask every time.

How would we fix this? Probably with arrays:

Dim lastRow As Long

Dim rdate As Variant
lastRow = wsrgcmes.Cells(Rows.Count, 23).End(xlUp).Row
rdate = wsrgcmes.Range(wsrgcmes.Cells(1, 23), wsrgcmes.Cells(lastRow, 23))

Dim rcaso As Variant
lastRow = wsrgcmes.Cells(Rows.Count, 2).End(xlUp).Row
rcaso = wsrgcmes.Range(wsrgcmes.Cells(1, 2), wsrgcmes.Cells(lastRow, 2))

Dim rtask As Variant
lastRow = wshtee.Cells(Rows.Count, 2).End(xlUp).Row
rtask = wshtee.Range(wshtee.Cells(1, 2), wshtee.Cells(lastRow, 2))

Now those three variants are populated with all the data you need and you only queried the sheet one time each. Now you can work with the data in the arrays (variants in this case) in VBA without touching the sheet.

For i = CDbl(DateSerial(Year(targetDate), Month(targetDate), 1)) To CDbl(targetDate)
        On Error Resume Next
        For j = LBound(rtask) To UBound(rtask)
            idcaso = rcaso(j - 1)
            fregistro = CDbl(Int(rcaso(j + 21)))
            If isFcierreTest Then
                fcierre = CDbl(Int(rcaso((j + 7))))
            End If
            Select Case testCondition
                Case 1
                If fregistro = i Then
                    contask = contask + 1
                End If
                Case 2
                If fregistro > CDbl(DateSerial(Year(Date), Month(Date), 0)) And fcierre = i Then
                    contask = contask + 1
                End If
                Case 3
                If fregistro < CDbl(DateSerial(Year(Date), Month(Date), 1)) And fcierre = i Then
                    contask = contask + 1
                End If
                Case Else
            End Select

I think I got that right, but I didn't test it so make sure. You could also create a resultArray to populate the ActiveCell.Offset(targetRow,x).Value by storing it all and then writing it once to the sheet.

targetSheet.range('targetRange) = resultArray

Once again, that's pretty generic, so don't rely on it. Backup all your data before trying any of this.