Return to Answer

• 1

• 7.3k
• 1
• 23
• 60

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.