Speeding up VBA code

Question

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

hello, to begin with please try to get rid of .select in your codes. Instead of that you can simply write your range. For example: instead of Range(Cells(i, h), Cells(i + 2, h)).Select and With Selection.Interior you can use Range(Cells(i, h), Cells(i + 2, h)).Interior — Dubison
– Dubison, Commented Apr 28, 2015 at 16:00
That is indeed a wall of code... If it's taking up so much memory, you likely either have a leak, an inefficient algorithm running on your data, or too much data. How big is the "full extent if your data"? — Krease
– Krease, Commented Apr 28, 2015 at 16:01
@Chris it's 3447x5400, it certainly is a lot of data but I thought Excel 64-bit would be able to handle it with 16GB memory on the machine. — hc91
– hc91, Commented Apr 28, 2015 at 16:12
Instead of repeating this over and over: Worksheets("Zeroes").Cells(MedianLook, colNum)... you can do something like Dim rw As Range: Set rw = Worksheets("Zeroes").Rows(MedianLook) and then after that use rw.Cells(colNum). Your code will look much cleaner and using a variable will likely speed it up (a little). Also, it's best never to write your code so it relies on a particular sheet being active: always qualify all calls to Range() and Cells() with a Worksheet object. — Tim Williams
– Tim Williams, Commented Apr 28, 2015 at 16:24

Craig Weinzapfel · Accepted Answer · 2015-04-28 16:40:55Z

3

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

edited Apr 28, 2015 at 16:40

answered Apr 28, 2015 at 16:35

Craig Weinzapfel

2663 silver badges3 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

hc91 Over a year ago

Thanks @CraigWeinzapfel i'm now in the process of changing it to your suggestion.

hc91 Over a year ago

I cannot make it actually change the value of, for example, valsf(i, h) = (valsf(i - 1, h) + valsf(i + 1, h)) / 2 it will only change when i make it Cells(i, h) = (valsf(i - 1, h) + valsf(i + 1, h)) / 2. Why is this?

Craig Weinzapfel Over a year ago

This is because the valsf array of data is not actually referencing the range. When you assign the Range().Value2 to the valsf array, the data is actually copied over to the valsf from the range. So in order to update the range values again you must assign the valsf values to the range. I do this in my example above by assigning the entire vals array to my entire range. If you individually reassign each value to its specific cell the benefits of manipulating/testing the values in valsf will be far limited compared to the way I illustrated in my example.

Collectives™ on Stack Overflow

Speeding up VBA code

1 Answer 1

3 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

3 Comments

Your Answer

Sign up or log in

Post as a guest

Related