31 May 2009

VBA code to calculate par for zero-sum butler

Function par(ByVal scores As Range, Optional ByVal delta As Integer = 10)
    ' scores is the range of cells containing the scores
    ' delta  is the smallest difference between scores
    On Error GoTo par_error
        If scores.Count = 1 Then    ' dispose of trivial case
            par = scores.Value
            Exit Function
        End If
        
        Dim data
        data = scores   ' read range into array, for efficiency
        Debug.Assert IsArray(data)
        
        Dim par1 As Integer, par2 As Integer
        Dim sum1 As Integer, sum2 As Integer
        ' set initial values to bracket the par value
        par2 = 8000
        par1 = -par2
        sum2 = scores.Count
        sum1 = -sum2
        While par2 - par1 > delta
            par = delta * Fix((par1 + par2) / (2 * delta))
            
            Dim sum As Integer, i As Integer, j As Integer
            sum = 0
            ' calculate the net sum of imp scores against par
            ' imp_() is a function to calculate the IMP scale
            For i = LBound(data, 1) To UBound(data, 1)
                For j = LBound(data, 2) To UBound(data, 2)
                    sum = sum + imp_(par - data(i, j))
                Next j
            Next i
            If sum = 0 Then Exit Function
            ' if we haven't found par, adjust the bracket
            If sum < 0 Then
                par1 = par
                sum1 = sum
            Else
                par2 = par
                sum2 = sum
            End If
            ' check we haven't lost the plot!
            Debug.Assert par1 < par2 And sum1 < 0 And 0 < sum2
        Wend
        ' if we can't find a par value giving sum = 0
        ' take the par will the smallest sum ...
        If (-sum1) < sum2 Then
            par = par1
        ElseIf sum2 < (-sum1) Then
            par = par2
        ' ... splitting ties choosing par nearer zero
        ElseIf par2 > 0 Then
            par = par1
        Else
            par = par2
        End If
    Exit Function
par_error:
    MsgBox "Error in par: " & Err.Description
    par = CVErr(xlErrValue)
End Function

No comments: