A d’Hondt() Excel function

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

Leave a Reply

Your email address will not be published. Required fields are marked *