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
31 May 2009
VBA code to calculate par for zero-sum butler
Subscribe to:
Post Comments (Atom)
No comments:
Post a Comment