Speed up code? This simple VBA code makes me a report but its taking 15 minutes to finish.

This macro is for a bus workshop, it reviews the excel DB and makes me a report of all the expenses per bus which ends up giving 2k rows.

Can you please tell me how to speed up this macro? 15 minutes is a lot of time.

Sub getallExpensesperbus()

Application.ScreenUpdating = False
    
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim selectsheet As Worksheet

Dim idcamion As String
Dim finalrow As Integer
Dim i As Integer

Set datasheet = Page1
Set reportsheet = Page2
Set selectsheet = Page3

reportsheet.Select
reportsheet.Range("A4:K300000").ClearContents
Sheets("BDproducts").Visible = True
datasheet.Select
finalrow = Page1.Range("Q2").Value

For i = 2 To finalrow
    If Cells(i, 8).Value <> "" Then
    price = Cells(i, 3).Value
    ID = Cells(i, 2).Value
    product = Cells(i, 1).Value
    unit = Cells(i, 4).Value
    quantity = Cells(i, 5).Value
    address = Cells(i, 9).Value
    time = Cells(i, 10).Value
    comments = Cells(i, 7).Value
    side = Cells(i, 13).Value
    mileage = Cells(i, 14).Value
    bus= Cells(i, 8).Value
    
    reportsheet.Select
    finalrow2 = WorksheetFunction.CountA(Range("A:A")) + 2
    
    Cells(finalrow2, 1).Value = bus
    Cells(finalrow2, 2).Value = product
    Cells(finalrow2, 3).Value = ID
    Cells(finalrow2, 4).Value = unit
    Cells(finalrow2, 5).Value = quantity
    Cells(finalrow2, 6).Value = price
    
    Cells(finalrow2, 7).Value = adress
    Cells(finalrow2, 8).Value = time
    Cells(finalrow2, 9).Value = comments
    Cells(finalrow2, 10).Value = side
    Cells(finalrow2, 11).Value = mileage
    
    datasheet.Select
    End If
Next i

reportsheet.Select
    Range("A4").Select

Application.ScreenUpdating = True

End Sub