I saw a spreadsheet with some VBA macros recently to calculate numbers of seats awarded in elections conducted using the d’Hondt system, so I thought I’d have a go at a single Excel function to do the same. WordPress doesn’t allow the Excel workbooks with VBA to be uploaded, so the file which can be downloaded from this link needs to have the following code added in a module
3rd June 2020 I had a comment from Daniel Martinez pointing out a bug. Hope I have fixed this now, and also addressed the problem of ties
Option Explicit Public Function dHondt(iSeatsToAllocate As Integer, rVotes, Optional lVoters As Long = 10000) Dim dVoteTotal As Double Dim dVote Dim i As Integer Dim aSeats() Dim dVotes() As Double Dim blnColumn As Boolean Dim dSeatCostTrial As Double Dim nSeatsTrial As Integer Dim nParties As Integer Dim iTries As Integer Dim dUpperLimit As Double, dLowerLimit As Double Dim blnScaled As Boolean Dim dChange As Double On Error GoTo eh dVotes = asSingleArray(rVotes, blnColumn) nParties = UBound(dVotes) + 1 'The algorithm looks for a cost per seat which will allocate the number of seats available 'starting with upper and lower limits, and the first trial cost per seat the upper limit 'One or other of these limits is set to the mid point of their range, according to whether the 'number of seats allocated at the trial cost per seat is above or below the number to allocate 'Where there are ties in the number of votes, the basic d'Hondt process will not be able to 'allocate seats, so some other tie breaking process will be needed. This condtion is tested for 'by seeing if the difference between upper and lower limits is less than a single vote. For this 'to work when percentages are given, a total number of votes is needed. This is an option third 'argument to the function. By default it is 10,000 'Lower limit For Each dVote In dVotes dVoteTotal = dVoteTotal + dVote If dVote <> Int(dVote) Then blnScaled = True If dLowerLimit = 0 Then If dVote > 0 Then dLowerLimit = dVote Else If dVote > 0 And dVote < dLowerLimit Then dLowerLimit = dVote End If Next dSeatCostTrial = dVoteTotal / iSeatsToAllocate ' - always high dUpperLimit = dSeatCostTrial dLowerLimit = dLowerLimit / iSeatsToAllocate While nSeatsTrial <> iSeatsToAllocate iTries = iTries + 1 ReDim aSeats(nParties - 1) nSeatsTrial = 0 For i = 0 To nParties - 1 aSeats(i) = Int(dVotes(i) / dSeatCostTrial) nSeatsTrial = nSeatsTrial + aSeats(i) Next If nSeatsTrial > iSeatsToAllocate Then ' adjust dSeatCostTrial up If dSeatCostTrial > dLowerLimit Then dLowerLimit = dSeatCostTrial ElseIf nSeatsTrial < iSeatsToAllocate Then ' adjust dSeatCostTrial down If dSeatCostTrial < dUpperLimit Then dUpperLimit = dSeatCostTrial End If dSeatCostTrial = (dUpperLimit + dLowerLimit) / 2 dChange = dUpperLimit - dLowerLimit If blnScaled Then dChange = dChange * lVoters If dChange < 1 Then Err.Raise 1, "dHondt", "Check for tied votes" Else dSeatCostTrial = (dUpperLimit + dLowerLimit) / 2 End If Wend tidyup: If blnColumn Then dHondt = WorksheetFunction.Transpose(aSeats) Else dHondt = aSeats End If Exit Function eh: For i = 0 To nParties - 1 aSeats(i) = Err.Description Next GoTo tidyup End Function Private Function asSingleArray(rVotes, blnColumn As Boolean) Dim i As Integer Dim aVotes Dim dVotes() As Double Select Case TypeName(rVotes) Case "Range" aVotes = rVotes.Value Case "Array" aVotes = rVotes Case Else Err.Raise 1, "", "" End Select On Error Resume Next blnColumn = UBound(aVotes, 2) <= 1 If Err.Number <> 0 Then 'single dim array ReDim dVotes(UBound(aVotes) - LBound(aVotes)) For i = 0 To UBound(aVotes) - LBound(aVotes): dVotes(i) = aVotes(i + LBound(aVotes)): Next ElseIf blnColumn Then ReDim dVotes(UBound(aVotes) - LBound(aVotes)) For i = 0 To UBound(aVotes) - LBound(aVotes): dVotes(i) = aVotes(i + LBound(aVotes), LBound(aVotes, 2)): Next Else ReDim dVotes(UBound(aVotes, 2) - LBound(aVotes, 2)) For i = 0 To UBound(aVotes, 2) - LBound(aVotes, 2): dVotes(i) = aVotes(LBound(aVotes), i + LBound(aVotes, 2)): Next End If asSingleArray = dVotes End Function
The function needs first the number of seats to allocate, and then an Excel row or column range with the votes cast, or percentages, so something like
The output is another Excel range, a row or column as the case may be, with the number of seats awarded under d’Hondt. Those curly braces are the result of the function being entered as an array formula – something to look up for those unfamiliar with these.
I’ve also written it so that it can be used more simply in VBA with just a single dimension array as the second argument.
Copyright? I’m really not too bothered, and I’m sure plenty of other people have done something like this, but yes, acknowledgement is appreciated.
23rd April, 2019