Counting days until threshold reached

Sub get_dates()


Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, r As Long, c As Long, n1 As Long, n2 As Long
Dim lastrow As Long, Lastcol As Long
Dim inarr, outarr

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  'Application.Calculation = xlCalculationManual

Set ws1 = Worksheets("Sheet1")
ws1.Activate

With ws1

    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    Lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    inarr = .Range(.Cells(2, 1), .Cells(lastrow, Lastcol))
    
    ReDim outarr(1 To UBound(inarr, 1), 1 To 3)
    
    Crop = inarr(1, 1)
    c = 1
    
    For l = 200 To 400 Step 100
        
        For r = 1 To UBound(inarr, 1)
        
            If inarr(r, 1) <> Crop Then Crop = inarr(r, 1)
               tsum = 0
               j = r
               Do While tsum < l
                 If inarr(j, 1) <> Crop Then GoTo nextr
                  tsum = tsum + inarr(j, 4)
                  j = j + 1
                  If j > UBound(inarr, 1) Then
                    If tsum >= l Then outarr(r, c) = WorksheetFunction.Max(inarr(j - 1, 2) - inarr(r, 2) + 1, 0)
                    GoTo nextr
                  End If
               Loop
               outarr(r, c) = WorksheetFunction.Max(inarr(j - 1, 2) - inarr(r, 2) + 1, 0)
nextr:
        Next r
     c = c + 1
    Next l

End With

ws1.Range("E2").Resize(UBound(outarr, 1), UBound(outarr, 2)) = outarr

'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub