CODEWITHSUNDEEP
excelvba
Damian M
Damian M

Reputation: 47

Assistance with slow VBA

This code has taken a couple of hours so far and less than 10% complete, please advise how I can make this faster?

I have tried to explain the code by using comments in the code

Sheet1 has nearly 500k rows on dates, from 1 July 1990 to 30/6/2017 in 30 minute intervals, i.e. 48 rows per day.

I have a table on a different worksheet with a row of 12 columns displaying months 7 to 6, then below the month number in 3 rows are 3 different years

Sub Test2()

Application.ScreenUpdating = False

'Sheet1 contains the main data set
'Sheet3 contains a table with 12 columns and 3 rows
'Sheet2 is an output sheet
'Sheet4 is an output sheet
'Sheet5 is an output sheet

Dim i As Long 'main sheet rows (Sheet1 473,379 rows)
Dim j As Long 'Columns (Table of dates with 12 columns on sheet3)
Dim LastRowMain As Long 'Last row of sheet 1
Dim LastRowStitch As Long 'Lastrow of the applicable output sheet

Dim Yr As Integer
Dim Mnth As Integer

LastRowMain = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row '473,379 rows

j = 3 'First data column in the table

Do Until j = 14

    For i = 4 To LastRowMain

        'Sheet1 column(1) is Date format in 1/2 hour intervasls, i.e. 48 rows per day
        Yr = Year(Sheet1.Cells(i, 1))
        Mnth = Month(Sheet1.Cells(i, 1))

        If Yr = Sheet3.Cells(2, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
            LastRowStitch = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
            Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet2.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
        End If

        If Yr = Sheet3.Cells(3, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
            LastRowStitch = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
            Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet4.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
        End If

        If Yr = Sheet3.Cells(4, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
            LastRowStitch = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
            Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet5.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
        End If

    Next i

Loop 'Go to the next set of dates in the table and loop through the rows again


Application.ScreenUpdating = True

MsgBox "Done"

End Sub

Many thanks

Upvotes: 0

Views: 74

Answers (2)

AcsErno
AcsErno

Reputation: 1615

Refactoring a bit: 

Dim YrToCompare2 As Long, YrToCompare4 As Long, YrToCompare5 As Long
Dim MnthToCompare as Long
Dim LastRow2 As Long, LastRow4 As Long, LastRow5 As Long

LastRow2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
LastRow4 = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
LastRow5 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row

Do Until j = 14

    MnthToCompare = Sheet3.Cells(1, j)
    YrToCompare2 = Sheet3.Cells(2, j)
    YrToCompare4 = Sheet3.Cells(3, j)
    YrToCompare5 = Sheet3.Cells(4, j)

    For i = 4 To LastRowMain

    'Sheet1 column(1) is Date format in 1/2 hour intervasls, i.e. 48 rows per day
       Yr = Year(Sheet1.Cells(i, 1))
       Mnth = Month(Sheet1.Cells(i, 1))

       If Yr = YrToCompare2 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
           LastRow2 = LastRow2 + 1
           Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet2.Cells(LastRow2, 1) 'Copy that row and put in in to the output sheet below the lastrow
       End If

       If Yr = YrToCompare4 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
           LastRow4 = LastRow4 + 1
           Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet4.Cells(LastRow4, 1) 'Copy that row and put in in to the output sheet below the lastrow
       End If

       If Yr = YrToCompare5 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
            LastRow5 = LastRow5 + 1
            Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet5.Cells(LastRow5, 1) 'Copy that row and put in in to the output sheet below the lastrow
      End If

   Next i

   j = j + 1

Loop 'Go to the next set of dates in the table and loop through the rows again

The concept is to reduce VBA - Excel interactions by storing relatively fixed values in variables instead of reading them from Excel 12*500K times, and also counting last rows instead of finding them in every loop. However, you can expect significant improvement by implementing @QHarr's advise on using arrays.

Upvotes: 1

kulapo
kulapo

Reputation: 397

Aside from ScreenUpdating and EnableEvents, you can also set the Calculation to manual before running your code. Normally, Excel will automatically recalculate a cell or a range of cells when that cell's or range's precedents have changed.

Application.Calculation = xlCalculationManual

Then once the loop is done, turn it on again:

Calculate
Application.Calculation = xlAutomatic

Upvotes: 1

Related Questions