Sub AssignTeams()

Dim team_count As Integer Dim max_day As Integer Dim Tasks() As Variant Dim Teams() As Variant

ReDim Tasks(0 To 5, 0 To 3) 'You'll have to dynamically make this the right size! ReDim Teams(0 To 1, 1 To 1) team_count = 1

'Get max day - I'll leave this to you to make dynamic! max_day = 55

'Read in TaskID, StartDate, and EndDate values '(Assumes they are stored in Columns A, B, and C, respectively). For i = 0 To UBound(Tasks) Tasks(i, 0) = Cells(i + 2, 1) Tasks(i, 1) = Cells(i + 2, 2) Tasks(i, 2) = Cells(i + 2, 3) Next i

For d = 1 To max_day

For i = 0 To UBound(Tasks)
j = 1

    'Check if Task can start today
    If (Tasks(i, 1)) = d Then
        'Task can start, find a team to assign.

        'Calculate rest of teams (negative numbers imply days off)
        'Helps pick the team with the most rest
        'when more than one team can start.
        most_rest = Teams(1, 1)
        most_rest_team_id = 1
        For j = 1 To team_count
            If (Teams(1, j) < most_rest) Then
                most_rest = Teams(1, j)
                most_rest_team_id = j
            End If
        Next j

        'Check if a team is available and
        'pick team that has had the most rest.
        If most_rest <= 0 Then
            'Team is available.
            Teams(0, most_rest_team_id) = "Team-" & most_rest_team_id
            Tasks(i, 3) = Teams(0, most_rest_team_id)
            Teams(1, most_rest_team_id) = Tasks(i, 2)
        Else
            'A team is not avaiable
            'Add a new team.
            team_count = team_count + 1
            ReDim Preserve Teams(0 To 1, 1 To team_count)
            Teams(0, team_count) = "Team-" & team_count
            Tasks(i, 3) = Teams(0, team_count)
            Teams(1, team_count) = Tasks(i, 2)
        End If
    Else
        'Task not ready to start.
        'Go on to next task or increment day if there are no more tasks for the current day.
        If (i = UBound(Tasks)) Then

            'Go to the next day
            current_day = current_day + 1

            'Decrease the time left to work for assinged tasks
            For t = 1 To team_count
                Teams(1, t) = Teams(1, t) - 1
            Next t
        End If
    End If

Next i

Next d

'Print out the Assignments For i = 0 To UBound(Tasks)

Cells(i + 2, 5) = Tasks(i, 0)
Cells(i + 2, 6) = Tasks(i, 1)
Cells(i + 2, 7) = Tasks(i, 2)
Cells(i + 2, 8) = Tasks(i, 3)

Next i

End Sub