**SCA Chess ****Camp**** ****Ladder**** Rating
Algorithm**

If there is a winner (not a draw):

If the winner's rating is 375 or less more than the loser's rating:

Winner's rating changes by:

16 added to it

and also

1/25 of the difference subtracted from it.

Loser's rating changes by:

16 subtracted from it

and also

1/25 of the difference added to it.

If the winner's rating is 376 or more greater than the loser's rating:

Winner's rating changes by:

1 added to it

Loser's rating changes by:

1 subtracted from it

If the winner's rating is 375 or less below the loser's rating:

Winner's rating changes by:

16 added to it

and also

1/25 of the difference added to it.

Loser's rating changes by:

16 subtracted from it

and also

1/25 of the difference subtracted from it.

If the winner's rating is 376 or more below the loser's rating:

Winner's rating changes by:

31 added to it

Loser's rating changes by:

31 subtracted from it

If it is a draw:

If the higher rated player's rating is 375 or less more than the opponent's rating:

Player's rating changes by:

1/25 of the difference subtracted from it.

Opponent's rating changes by:

1/25 of the difference added to it.

If the higher rated player's rating is 376 or more greater than the opponent's rating:

Player's rating changes by:

15 subtracted from it

Opponent's rating changes by:

15 added to it

Following is the Visual Basic for Application (VBA) code. The rating of interest is the Weekly Rating. The Permanent Rating is only used for internal comparison purposes. It is not the posted rating.

Public Sub Recalc_Ratings()

Dim Count As Integer ' Players left to process

Dim Games As Integer ' Games left to process

Dim WPRating As Integer ' Weekly Player Rating

Dim WORating As Integer ' Weekly Opponent Rating

Dim PPRating As Integer ' Permanent Player Rating

Dim PORating As Integer ' Permanent Opponent Rating

Dim DefaultRating As Integer ' Rating based on Group

Dim sqlCommand As String

Dim Group As String

Dim Outcome As String

Dim myDB As Object

Dim trs As Object

Dim grs As Object

Dim Dbug As Boolean

DoCmd.Hourglass True

Dbug = False

Set myDB = CurrentDb

Set trs = myDB.OpenRecordset("Ladder Players")

trs.MoveFirst

DoCmd.SetWarnings False

Do While Not trs.EOF

'''First reset all campers' ratings back to their start-of-week ratings based on group

If trs.Active Then

Group = trs.Group

DefaultRating = DLookup("[Initial Ladder Rating]", "Camp Groups", "Group = '" & Group & "'")

trs.Edit

trs!Rating = DefaultRating

trs.Update

End If

trs.MoveNext

trs.Close

'''Then reset all campers' permanent ratings back to their start-of-week permantent ratings

DoCmd.RunSQL ("Update [Ladder Players] SET [Permanent Rating] = [StWkPerm] " & _

"WHERE ACTIVE = YES")

''' Get next game from the [Ladder Games] table and process it

'''grs = Games Record Set

Set grs = myDB.OpenRecordset("Ladder Games")

Games = grs.RecordCount

If Games = 0 Then

'Nothing to calculate.

DoCmd.Hourglass False

DoCmd.SetWarnings True

Exit Sub

End If

grs.MoveFirst

Do While Not grs.EOF

WPRating = Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.White))

WORating = Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.Black))

PPRating = Nz(DLookup("[Permanent Rating]", "[Ladder Players]", "[ID] = " & grs.White))

PORating = Nz(DLookup("[Permanent Rating]", "[Ladder Players]", "[ID] = " & grs.Black))

Outcome = grs.Result

If Dbug Then MsgBox ("Before: Player = " & WPRating & " Opponent = " & WORating)

If Dbug Then MsgBox ("Result =[" & Outcome & "]")

If Outcome = "(1-0)" Then

'''Update the Permanent Rating for the player (winner)

sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PPRating + 16 - _

IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PPRating - PORating), _

Int((Abs(PPRating - PORating)) / 25) * Sgn(PPRating - PORating)) _

& " WHERE [ID] = " & grs.White

If Dbug Then MsgBox (sqlCommand)

DoCmd.RunSQL (sqlCommand)

'''Update the Permanent Rating for the opponent (loser)

sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PORating - 16 - _

IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PORating - PPRating), _

Int((Abs(PORating - PPRating)) / 25) * Sgn(PORating - PPRating)) _

& " WHERE [ID] = " & grs.Black

If Dbug Then MsgBox (sqlCommand)

DoCmd.RunSQL (sqlCommand)

'''Update the Weekly Rating for the player (winner)

sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WPRating + 16 - _

IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WPRating - WORating), _

Int((Abs(WPRating - WORating)) / 25) * Sgn(WPRating - WORating)) _

& " WHERE [ID] = " & grs.White

If Dbug Then MsgBox (sqlCommand)

DoCmd.RunSQL (sqlCommand)

'''Update the Weekly Rating for the opponent (loser)

sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WORating - 16 - _

IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WORating - WPRating), _

Int((Abs(WORating - WPRating)) / 25) * Sgn(WORating - WPRating)) _

& " WHERE [ID] = " & grs.Black

If Dbug Then MsgBox (sqlCommand)

DoCmd.RunSQL (sqlCommand)

Else ' must have been a draw

'''Update the Permanent Rating for the player

sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PPRating - _

IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PPRating - PORating), _

Int((Abs(PPRating - PORating)) / 25) * Sgn(PPRating - PORating)) _

& " WHERE [ID] = " & grs.White

If Dbug Then MsgBox (sqlCommand)

DoCmd.RunSQL (sqlCommand)

'''Update the Permanent Rating for the opponent

sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PORating - _

IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PORating - PPRating), _

Int((Abs(PORating - PPRating)) / 25) * Sgn(PORating - PPRating)) _

& " WHERE [ID] = " & grs.Black

DoCmd.RunSQL (sqlCommand)

'''Update the Weekly Rating for the player

sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WPRating - _

IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WPRating - WORating), _

Int((Abs(WPRating - WORating)) / 25) * Sgn(WPRating - WORating)) _

& " WHERE [ID] = " & grs.White

DoCmd.RunSQL (sqlCommand)

'''Update the Weekly Rating for the opponent

sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WORating - _

IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WORating - WPRating), _

Int((Abs(WORating - WPRating)) / 25) * Sgn(WORating - WPRating)) _

& " WHERE [ID] = " & grs.Black

DoCmd.RunSQL (sqlCommand)

End If

If Dbug Then MsgBox ("After: Player = " & Nz(DLookup("[Rating]", "[Ladder Players]", _

"[ID] = " & grs.White)) & _

"Opponent = " & Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.Black)))

grs.MoveNext

DoCmd.SetWarnings True

grs.Close

DoCmd.Hourglass False

MsgBox ("Recalc Ratings Done")

End Sub