Excel VBA – Activity Selection Algorithm

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 (s_i) and finish time (f_i). 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:

a1  1   3
a3  4   7
a6  8   10
a8  11  14

This is the code in the module:

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:

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