VBA to find first available slot

[kapi98]

Hi there.

I was wondering if it'd be possible for Excel to find the next available spot for job that needs to be completed.

All the details and the sample file is included in my original post.

https://www.excelforum.com/excel-programming-vba-macros/1351595-vba-to-find-first-available-slot.html#post5527778

Thanks for your help

 

[kapi98]

Hi Peter,

Thanks for this code. Could you please adjust it a little bit?

Please find attached a mini sheet as requested.

Sample.xlsm
	A	B	C	D	E	F
5	START DATE	START TIME	HRS PREDICT	DAYS PREDICT	FINISH DATE	FINISH TIME
6	21/04/21	2:00 PM	19.2	2.40	27/04/21	8:42 AM
7	27/04/21	9:00 AM	8.5	1.06	28/04/21	9:30 AM
8	29/04/21	8:00 AM	15.75	1.97	30/04/21	3:45 PM
9	30/04/21	3:00 PM	6.75	0.84	3/05/21	1:15 PM
10	4/05/21	2:00 PM	21	2.63	7/05/21	10:30 AM
SCHEDULE

Cell Formulas
Range	Formula
D6:D10	D6	=IF(C6>0,C6/8,"")
E6:E10	E6	=IF(A6<>"",IF(B6<>"",IF(D6<>"",IF((D6-TRUNC(D6))/3+B6>0.6875,IF(D6<>"",IF(A6<>"",WORKDAY(A6,D6+1,Holidays),""),""),IF(D6<>"",IF(A6<>"",WORKDAY(A6,D6,Holidays),""),"")),""),""),"")
F6:F10	F6	=IF(B6<>"",IF(D6<>"",IF((D6-TRUNC(D6))/3+B6>0.6875,(D6-TRUNC(D6))/3+B6-0.6875+0.3333333,(D6-TRUNC(D6))/3+B6),""),"")

Named Ranges
Name	Refers To	Cells
Holidays	=Sheet2!$A$2:$A$8	E6:E10

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A7:B10	Expression	=AND($A7<=$E6,$B7<$F6)	text	NO

Cells with Data Validation
Cell	Allow	Criteria
B6:B10	Time	between 8:00:00 AM and 4:00:00 PM

 

[Peter_SSs]

Could you please adjust it a little bit?

Try ..

Sub ScheduleJobs_v2()
  Dim SL As Object
  Dim a As Variant
  Dim i As Long
  Dim st As Date, prevend As Date
  
  Set SL = CreateObject("System.Collections.Sortedlist")
  With Sheets("SCHEDULE")
    With .Range("A6", .Range("C" & Rows.Count).End(xlUp))
      a = .Value
      For i = 1 To UBound(a)
        SL.Add a(i, 1) + a(i, 2) & Format(i, "|0000"), i
      Next i
      For i = 0 To SL.Count - 1
        st = Split(SL.GetKey(i), "|")(0)
        If i > 0 Then prevend = .Cells(i, 5) + .Cells(i, 6)
        If st < prevend Then st = WorksheetFunction.Ceiling(prevend, 1 / 48)
        .Rows(1).Offset(i).Value = Array(Int(st), st - Int(st), a(SL.GetByIndex(i), 3))
      Next i
    End With
  End With
End Sub

 

[kapi98]

Hi mate,

Thanks for that. Unfortunately, Excel shows this error when I try to run this code.

 

[Peter_SSs]

Excel shows this error when I try to run this code.

Looks like your Windows system might be missing something required for that method. Rather than trying to track that down, now that I have a better feel for what you have, maybe this alternative (simpler) approach might be better anyway, ?

Sub ScheduleJobs_v3()
  Dim i As Long
  Dim st As Date, prevend As Date
  
  Application.ScreenUpdating = False
  With Sheets("SCHEDULE").Range("A6", Sheets("SCHEDULE").Range("C" & Rows.Count).End(xlUp))
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo
    For i = 2 To .Rows.Count
      st = .Cells(i, 1).Value + .Cells(i, 2).Value
      prevend = .Cells(i - 1, 5).Value + .Cells(i - 1, 6).Value
      If st < prevend Then
        st = WorksheetFunction.Ceiling(prevend, 1 / 48)
        .Cells(i, 1).Resize(, 2).Value = Array(Int(st), st - Int(st))
      End If
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

 

[kapi98]

Thanks mate. I'll give it a go in the morning. Cheers

 

[kapi98]

Hi mate,

Thank you very much for your help. It all seems to work well.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.