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

• Raystafarian: Please post the entirety of the code rather than a fragment, the bottleneck could be the result of something else. If this is all of the code, please clarify that instead of just "fragment"
• Datalyzer: @Raystafarian hey, thanks a lot for your input! And your answer! It explains a lot of what I need to do, I will start checking it asap. And that's pretty much all the sub. I have another sub tho, that sub reads all the info from 3 files and copy the info to the current workbook in 3 different sheets. Don't know if I should post that as well. Thanks a lot again!

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.