Speed up Loops in VBA - excel

Question

I'm currently using 2 if loops and a do loop to get my result. But this is proving to be extremely slow and usually crashing. The file is around 16MB. Secondly, it is not correctly changing the start date in Sheet 1 for all dates i.e. sometimes if the date is less than the Startofweek. It will still give the initial date.
In sheet "Leasing". Column A contains Car numbers, Column E contains the Start Date and Column F contains the End Date.
Sheet 1 will be where the results are needed. Column A the start date, B the end Date and C the Car number.
I need it to give me the car number in Sheet 1:
i) If car number is not blank then
if the end date in Leasing is blank.
a) End date in Sheet 1 would be Endofweek(inputted by user)
b) Start date in Sheet 1would be Startofweek(inputted by user) or Start Date(Leasing). Whichever is greater.
if end date is less than Endofweek but greater than startofweek.
a) End date in Sheet 1 would be EndDate leasing
b) Start date in Sheet 1would be Startofweek(inputted by user) or Start Date(Leasing). Whichever is greater.
Column D of Sheet 1 then contains the difference between End of week and Start of week(Column B - Column A)
Example: Startofweek: 22/3/21, Endofweek: 28/3/21
'''
Sub active_leasing_cars()
Application.ScreenUpdating = False
Const Leasing_start = 5 'Column leasing start from Leasing Hisaab
Const Leasing_end = 6 'Column Leasing start from leasing Hisaab
Const Leasing_car = 1
Const TARGET = "Sheet1"
Const LEASING = "Leasing Hisaab"
Dim wb As Workbook, ws As Worksheet, wsResult, wsLeasing As Worksheet
Dim i, j, iLastrow As Integer
Dim Endofweek, Startofweek As String
Set wb = ThisWorkbook
Set wsResult = wb.Sheets(TARGET)
Set wsLeasing = wb.Sheets(LEASING)
iLastrow = wsLeasing.Cells(Rows.Count, Leasing_car).End(xlUp).Row
i = 1
j = 2
Endofweek = InputBox("Please enter end date", "Enter Date", Format(Date, "dd/mm/yyyy"))
Startofweek = InputBox("Please enter start date ", "Enter Date", Format(Date, "dd/mm/yyyy"))
Do
i = i + 1
If wsLeasing.Cells(i, Leasing_car) = "" Then
If wsLeasing.Cells(i, Leasing_end) = "" Then
wsResult.Cells(j, 2) = Endofweek
If wsLeasing.Cells(i, Leasing_start) <= Startofweek Then
wsResult.Cells(j, 1).Value = Startofweek
Else: wsResult.Cells(j, 1) = wsLeasing.Cells(i, Leasing_start)
End If
ElseIf wsLeasing.Cells(i, Leasing_end) >= Startofweek And wsLeasing.Cells(i, Leasing_end) <= Endofweek Then
wsResult.Cells(j, 2) = wsLeasing.Cells(i, Leasing_end)
If wsLeasing.Cells(i, Leasing_start) <= Startofweek Then
wsResult.Cells(j, 1) = Startofweek
Else: wsResult.Cells(j, 1) = wsLeasing.Cells(i, Leasing_start)
End If
End If
wsResult.Cells(j, 3) = wsLeasing.Cells(i, Leasing_car)
wsResult.Cells(j, 4) = DateDiff("d", wsResult.Cells(j, 1), wsResult.Cells(j, 2))
j = j + 1
End If
Loop While i < iLastrow
Application.ScreenUpdating = True
End Sub

Answer 1

That shouldn't take too long. You've no formulae in your worksheets do you?
You could disable display updates and the automatic calculations via the below at the start of your macro, and see how you go:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
(don't forget to reenable at the end)
If that doesn't help, then a bit more work is required - I'd advise loading your data into a 2D array though and going from there.
Dim leasingData()
iRows = 0
Do Until isEmpty(Sheets("Leasing").cell(2+iRows,1))
redim preserve leasingData(2, iRows)
leasingData(0, iRows) = Sheets("Leasing").Cells(2 + iRows, 1)
leasingData(1, iRows) = Sheets("Leasing").Cells(2 + iRows, 5)
leasingData(2, iRows) = Sheets("Leasing").Cells(2 + iRows, 6)
iRows = iRows = 1
Loop
Then from there, your searching and indexing should be much faster. The slowest part of VBA is interacting with the worksheets.
for iCar = 0 to ubound(leasingData,2)
if leasingData(2, iCar) = "" then
'No end date specified for this car, sub in end of week
end if
if leasingData(1, iCar) <= Start of week then
'The car leaase started before the start of this week, so update to start of week
end if
next iCar
etc etc
Then you can push the data out of the array onto your result sheet:
for iCar = 0 to ubound(leasingData,2)
Sheets("Target").cells(1+iCar, 3) = leasingData(0, iCar)
Sheets("Target").cells(1+iCar, 1) = leasingData(1, iCar)
Sheets("Target").cells(1+iCar, 2) = leasingData(2, iCar)
next iCar
In terms of your end of week update problem:
ElseIf wsLeasing.Cells(i, Leasing_end) >= Startofweek And wsLeasing.Cells(i, Leasing_end) <= Endofweek Then
wsResult.Cells(j, 2) = wsLeasing.Cells(i, Leasing_end)
Will never do what you want it to, you need to replace the RHS with Endofweek

Answer 2

You date comparison does not work properly because you have declared Startofweek As String. As a result wsLeasing.Cells(i, Leasing_start) <= StartOfWeek is False when the date 28/07/2020 is compared to the string 22/03/2021.
Option Explicit
Sub active_leasing_cars()
Const Leasing_start = 5 'Column leasing start from Leasing Hisaab
Const Leasing_end = 6 'Column Leasing start from leasing Hisaab
Const Leasing_car = 1
Const TARGET = "Sheet1"
Const LEASING = "Leasing Hisaab"
Dim wb As Workbook, ws As Worksheet, wsResult, wsLeasing As Worksheet
Dim i As Long, j As Long, iLastrow As Long
Dim EndOfWeek As Date, StartOfWeek As Date, s As String
Dim ar, t0 As Single: t0 = Timer
Set wb = ThisWorkbook
Set wsResult = wb.Sheets(TARGET)
Set wsLeasing = wb.Sheets(LEASING)
iLastrow = wsLeasing.Cells(Rows.Count, Leasing_car).End(xlUp).Row
' end of week
s = InputBox("Please enter end date dd/mm/yyyy", "Enter END Date", Format(Date, "dd/mm/yyyy"))
If IsDate(s) Then
ar = Split(s, "/")
EndOfWeek = DateSerial(ar(2), ar(1), ar(0))
Else
MsgBox s & " is not a date", vbCritical
Exit Sub
End If
' start of week
s = InputBox("Please enter START date ", "Enter Start Date dd/mm/yyyy", Format(EndOfWeek - 6, "dd/mm/yyyy"))
If IsDate(s) Then
ar = Split(s, "/")
StartOfWeek = DateSerial(ar(2), ar(1), ar(0))
Else
MsgBox s & " is not a date)", vbCritical
Exit Sub
End If
' sanity check
If StartOfWeek > EndOfWeek Then
MsgBox "Start: " & StartOfWeek & " after End: " & EndOfWeek, vbCritical
Exit Sub
End If
Dim sCar As String, dtStart As Date, dtEnd As Date, val As Variant
j = 1 ' sheet1 row
Application.ScreenUpdating = False
For i = 2 To iLastrow
sCar = wsLeasing.Cells(i, Leasing_car).Value
If Len(sCar) > 0 Then
' check start date
val = wsLeasing.Cells(i, Leasing_start).Value
If Len(val) > 0 Then
dtStart = val
Else
MsgBox "Start date is blank", vbCritical, "Row " & i
End If
' End Dates
val = wsLeasing.Cells(i, Leasing_end).Value
If Len(val) = 0 Then
'if the end date in Leasing is blank.
'a) End date in Sheet 1 would be Endofweek(inputted by user)
dtEnd = EndOfWeek
Else
dtEnd = val
End If
' filter for dates
If dtEnd < StartOfWeek Or dtStart > EndOfWeek Then
' ignore as either already ended or not started yet
Else
'b) Start date in Sheet 1 would be Startofweek(inputted by user)
' or Start Date(Leasing). Whichever is greater.
If dtStart > StartOfWeek Then
wsResult.Cells(j, 1) = dtStart
Else
wsResult.Cells(j, 1) = StartOfWeek
End If
wsResult.Cells(j, 2) = dtEnd
wsResult.Cells(j, 3) = sCar
wsResult.Cells(j, 4).FormulaR1C1 = "=RC[-2]-RC[-3]"
j = j + 1
End If
End If
Next
wsResult.Columns("B:C").NumberFormat = "dd/mm/yyyy"
Application.ScreenUpdating = True
MsgBox j - 1 & " records found for " & StartOfWeek & " to " & EndOfWeek, _
vbInformation, Int(Timer - t0) & " seconds"
End Sub