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