Looking for ways how to optimize loop in VBA, Excel - arrays

Question

I have a working loop which is supposed to deal with dates in a big quantity (final result has 15 columns with 30K+ rows in each) and script is looping for considerable amount of time (30+ minutes).
I am looking for better way of looping through dataset (different loop type - For Each?, arrays?, avoiding collections?).
DataSet example - Yellow cells are static data I am dealing with, Green cells is desirable result
I am looping from lastrow to firstrow in Column A and putting results to columns E and F.
My current loop consists of For Next and Collections and code is as follows:
Set FindCol = ws.Range("1:1").Find(What:="Difference")
FindColNumber = FindCol.Column
lastc = FindColNumber
lastr = ws.Cells(ws.Rows.count, lastc).End(xlUp).Row
lastr2 = Cells(Rows.count, lastc).End(xlUp).Row
For P = lastr2 To 3 Step -1
lastr2 = P
lastr = P
For R = lastr To 3 Step -1
lastr = R
Set DatePosition = Cells(lastr2, lastc - 4)
Set DatePosition2 = Cells(lastr - 1, lastc - 4)
If col.count = 0 Then
col.Add DatePosition
Else: col.Add DatePosition, Before:=1
End If
If col2.count = 0 Then
col2.Add DatePosition
Else: col2.Add DatePosition2, Before:=1
End If
Next R
Next P
lastc2 = ws.Cells(2, ws.Columns.count).End(xlToLeft).Column + 1
lastr4 = ws.Cells(ws.Rows.count, lastc2).End(xlUp).Row
cnt = lastr4 + 1
For Each col_element In col
ws.Cells(cnt, lastc2) = col_element
cnt = cnt + 1
Next
Set col = New Collection
lastc2 = ws.Cells(2, ws.Columns.count).End(xlToLeft).Column + 1
lastr4 = ws.Cells(ws.Rows.count, lastc2).End(xlUp).Row
cnt = lastr4 + 1
For Each col_element In col2
ws.Cells(cnt, lastc2) = col_element
cnt = cnt + 1
Next
Set col2 = New Collection