hc91
Reputation: 773
Speeding up VBA code
firstly I apologise for posting such a large section of vba, however this is just a snippet! I've used my macro on a test section of data and it works fine. However, whilst using it on the full extent of the data (3447 rows x 5400 columns) it has run for 3 days without working. I then have run it line by line and it appears to be this section that is causing the problem. It is running off Excel 2013 64-bit and is using 7.5GB of memory currently but I believe this increases to full capacity of ~16GB later in the macro.
Any suggestions how to improve any of the code would be most appreciated.
Application.Calculation = xlManual
For j = 0 To NumberDays - 1
For h = 5 To NumberLinks + 4 'Columns
For i = 5 + j * 14 To 16 + j * 14 'Rows
If Cells(i, h) = 0 Then 'Found a 0 to be filled in
'Stop
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 Then _
'If hours starting 6 to 9 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If 'If3
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 14 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 Then _
'If hours starting 16 to 19 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Hours 6 to 8 are zero, fill hours 7 and 8 with hour 9 data
Cells(i + 1, h) = Cells(i + 2, h)
Cells(i, h) = Cells(i + 2, h)
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) <> 0 Then _
'Hours 6 and 7 are zero, fill hour 7 with hour 8
Cells(i, h) = Cells(i + 1, h)
End If
If i = 15 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours starting 17 to 19 are zero, fill hours 17 and 18 with hour 16 data
Cells(i + 1, h) = Cells(i - 1, h)
Cells(i, h) = Cells(i - 1, h)
End If
If i = 16 + j * 14 And Cells(i + 1, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours 18 to 19 are zero, fill hour 18 with hour 17 data
Cells(i, h) = Cells(i - 1, h)
End If
If Cells(i - 1, h) <> 0 And Cells(i + 1, h) <> 0 Then _
'One hour is zero, fill with average of preceding and subsequent hours' data
Cells(i, h) = (Cells(i - 1, h) + Cells(i + 1, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 5 sequential hours are zero
Range(Cells(i, h), Cells(i + 4, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 6 sequential hours are zero
Range(Cells(i, h), Cells(i + 5, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
'
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo Error:
End If
If i < 14 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) <> 0 Then _
'if four sequential hour are zero fill first and last from preceding and subsequent hours and middle two by average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 3, h) = Cells(i + 4, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
Cells(i + 2, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
End If
If i < 15 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) <> 0 Then _
'If three sequential hours are zero fill first and last from preceding and subsequent hours and middle one average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 2, h) = Cells(i + 3, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 3, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Except for last hour, fill two zero cells from preceding and subsequent ones
Cells(i, h) = Cells(i - 1, h)
Cells(i + 1, h) = Cells(i + 2, h)
End If
End If '(If 1)
ProfileWasRequired:
Next i
Next h
Next j
Application.Calculation = xlAutomatic
Upvotes: 0
Views: 101
Answers (1)
Craig Weinzapfel
Reputation: 256
I would suggest storing the range values before iterating through them anytime you can. Anytime you have to access values that you can see on the screen, it will be slower. You will not be able to update the borders or background this way though.
Here is an example using the "Cells" like you have above. On my machine it requires almost 2 seconds to loop through 65535 cells.
Sub UsingCells()
Dim tmr As Single
tmr = Timer
Dim i As Long
For i = 1 To 65535
Cells(i, 1) = Cells(i, 1)
Next i
Debug.Print Timer - tmr
End Sub
Here is an example using the the range values after being stored in memory. On my machine it requires about 30 milliseconds to loop through the same 65535 cells.
Sub UsingStoredValues()
Dim tmr As Single
tmr = Timer
Dim vals As Variant
vals = Range("A1:A65535").Value2
Dim i As Long
For i = 1 To 65535
vals(i, 1) = vals(i, 1)
Next i
Range("A1:A65535").Value2 = vals
Debug.Print Timer - tmr
End Sub
Upvotes: 3