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
d’Hondt workbook – with VBA stripped
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
={dhondt(Q$3,Q$4:Q$13)}
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.
Tim Lund
23rd April, 2019