Assistance with slow VBA - excel

Question

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

Answer 1

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.

Answer 2

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