Wikipedia says that the activity selection problem is a combinatorial optimization problem concerning the selection of non-conflicting activities to perform within a given time frame, given a set of activities each marked by a start time (si) and finish time (fi). The problem is to select the maximum number of activities that can be performed by a single person or machine, assuming that a person can only work on a single activity at a time.
It is a great example of a greedy algorithm – we simply take the activity that ends first and then we take the next one possible, which also finishes last. The above picture, translated to excel input looks like this:
What we need to solve the algorithm is one class for Activity, where we can have StartTime and EndTime and one sorting implementation. First we sort by EndTime, then we take the first one in the collection and we start looping. If the n-th sorted element has an available starting time and the smallest ending time, then it’s ok. It works automatically and provides the best solution. In our case it is like this:
|
1 2 3 4 |
a1 1 3 a3 4 7 a6 8 10 a8 11 14 |
This is the code in the module:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
Option Explicit Public Sub TestMe() Dim objA As clsActivity Dim colObjs As New Collection Dim rngCell As Range Dim strResult As String Dim i As Long Dim lngNextStart As Long: lngNextStart = 0 For Each rngCell In Range(Cells(1, 1), Cells(1, 11)) Set objA = Nothing Set objA = New clsActivity objA.StartTime = rngCell objA.Endtime = rngCell.Offset(1, 0) objA.Name = rngCell.Offset(2, 0) colObjs.Add objA Next rngCell Set colObjs = SortedCollection(colObjs) For i = 1 To colObjs.Count If colObjs.Item(i).StartTime > lngNextStart Then strResult = strResult & colObjs.Item(i).Name & vbTab & _ colObjs.Item(i).StartTime & vbTab & _ colObjs.Item(i).Endtime & vbCrLf lngNextStart = colObjs.Item(i).Endtime End If Next i Debug.Print strResult End Sub Public Function SortedCollection(myColl As Collection, Optional blnSortABC As Boolean = True) As Collection Dim i As Long Dim j As Long For i = myColl.Count To 2 Step -1 For j = 1 To i - 1 If blnSortABC Then If myColl(j).Endtime > myColl(j + 1).Endtime Then myColl.Add myColl(j), after:=j + 1 myColl.Remove j End If Else If myColl(j).Endtime < myColl(j + 1).Endtime Then myColl.Add myColl(j), after:=j + 1 myColl.Remove j End If End If Next j Next i Set SortedCollection = myColl End Function |
This is the code in the clsAction:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
Private pName As String Private pStartTime As Long Private pEndTime As Long Public Property Get Name() As String Name = pName End Property Public Property Let Name(value As String) pName = value End Property Public Property Get StartTime() As Long StartTime = pStartTime End Property Public Property Let StartTime(value As Long) pStartTime = value End Property Public Property Get Endtime() As Long Endtime = pEndTime End Property Public Property Let Endtime(value As Long) pEndTime = value End Property |