Макрос в Excel для расчета системы линейных уравнений при определении рейтинга в личном первенстве по баскетболу 
Sub РАСЧЕТ_Rt() Dim m(1 To 100, 1 To 100), n(1 To 100, 1 To 100), b1(1 To 100), b2(1 To 100), SSS(1 To 100), c(1 To 100) As Double Dim A(1 To 100, 1 To 100), b(1 To 100), R(1 To 100, 1 To 100), L(1 To 100, 1 To 100), Y(1 To 100), X(1 To 100) As Double Dim Z(100), P(100) As Double, Npa, Nek, Nce, Nlo As Integer Dim PaIp(1 To 100), EkIn(1 To 100), CeIt(1 To 100), EtLo(1 To 100), Del(1 To 100, 4), Otkl(1 To 100), Xcp1, Xcp2, NomerIg(100), Familia(100), Zkp(20), Pkp(20) As Variant Nig = Cells(1, 18): Nn = Cells(2, 18) For i = 1 To Nn For j = 1 To 12 m(i, j) = Cells(i, j) Next j, i For i = 1 To Nig NomerIg(i) = Cells(i + 4, 15) Familia(i) = Cells(i + 4, 16) Next i For i = 1 To Nn For j = 1 To 10 For k = 1 To 10 If j < 6 And k < 6 Then A(m(i, j), m(i, k)) = A(m(i, j), m(i, k)) + m(i, 11) + m(i, 12) If j > 5 And k > 5 Then A(m(i, j), m(i, k)) = A(m(i, j), m(i, k)) + m(i, 11) + m(i, 12) If j 5 Then A(m(i, j), m(i, k)) = A(m(i, j), m(i, k)) - m(i, 11) - m(i, 12) If j > 5 And k < 6 Then A(m(i, j), m(i, k)) = A(m(i, j), m(i, k)) - m(i, 11) - m(i, 12) Next k, j, i
For i = 1 To Nig For j = 1 To Nig If i j Then A(i, j) = A(i, j) / A(i, i) Next j A(i, i) = 1: c(i) = 1 Next i
For Ct = 1 To Nn For i = 1 To Nig For j = 1 To 10 If m(Ct, j) = i And j < 6 Then b1(m(Ct, j)) = b1(m(Ct, j)) + m(Ct, 11): b2(m(Ct, j)) = b2(m(Ct, j)) + m(Ct, 12) End If If m(Ct, j) = i And j > 5 Then b1(m(Ct, j)) = b1(m(Ct, j)) + m(Ct, 12): b2(m(Ct, j)) = b2(m(Ct, j)) + m(Ct, 11) End If Next j, i, Ct For i = 1 To Nig b(i) = 1000 * (b1(i) - b2(i)) / (b1(i) + b2(i)) Next For j = 1 To Nig A(Nig, j) = 1 / Nig Next b(Nig) = 2200
For t = 1 To Nig L(t, 1) = A(t, 1) R(1, t) = A(1, t) / A(1, 1) Next t Y(1) = b(1) / A(1, 1) For t = 2 To Nig R(t, t) = 1 j = 2 Do L(t, j) = A(t, j) R(t, j) = 0 For k = 1 To j - 1 L(t, j) = L(t, j) - L(t, k) * R(k, j) Next j = j + 1 Loop Until j > t R(t, t) = 1 Do L(t, j) = 0 R(t, j) = A(t, j) Y(t) = b(t) For k = 1 To t - 1 R(t, j) = R(t, j) - L(t, k) * R(k, j) Y(t) = Y(t) - L(t, k) * Y(k) Next R(t, j) = R(t, j) / L(t, t) Y(t) = Y(t) / L(t, t) j = j + 1 Loop Until j > Nig Next X(Nig) = Y(Nig) For t = Nig - 1 To 1 Step -1 X(t) = Y(t) For k = t + 1 To Nig X(t) = X(t) - R(t, k) * X(k) Next Next
For i = 1 To Nig For j = 1 To Nig If i j And X(i) < X(j) Then c(i) = c(i) + 1 Next j, i
' считаем ожидаемый счет игры For i = 1 To Nn SSa = SSa + m(i, 11) + m(i, 12) Next i SSa = SSa / Nn
For i = 1 To Nn Rtcr1 = 0: Rtcr2 = 0 Xcp1 = (X(m(i, 1)) + X(m(i, 2)) + X(m(i, 3)) + X(m(i, 4)) + X(m(i, 5))) / 5 Xcp2 = (X(m(i, 6)) + X(m(i, 7)) + X(m(i, 8)) + X(m(i, 9)) + X(m(i, 10))) / 5 For j = 1 To 10 If j < 6 Then Rtcr1 = Rtcr1 + (X(m(i, j)) / Xcp1) * X(m(i, j)) If j > 5 Then Rtcr2 = Rtcr2 + (X(m(i, j)) / Xcp2) * X(m(i, j)) Next j Rtcr1 = Rtcr1 / 4: Rtcr2 = Rtcr2 / 4 If m(i, 11) + m(i, 12) > 0 Then Z(i) = ((m(i, 11) + m(i, 12)) * (Rtcr1 - Rtcr2 + 1000)) / 2000 If m(i, 11) + m(i, 12) = 0 Then Z(i) = (SSa * (Rtcr1 - Rtcr2 + 1000)) / 2000 If m(i, 11) + m(i, 12) > 0 Then P(i) = (m(i, 11) + m(i, 12)) * (1000 - (Rtcr1 - Rtcr2)) / 2000 If m(i, 11) + m(i, 12) = 0 Then P(i) = (SSa) * (1000 - (Rtcr1 - Rtcr2)) / 2000 Next i
For i = 1 To Nn 'Cells(i, 13) = Z(i): Cells(i, 14) = P(i) Next i
For i = 1 To Nig 'PaIp(Cells(i + 4, 15)) = Cells(i + 4, 18): 'EkIn(Cells(i + 4, 15)) = Cells(i + 4, 19) 'CeIt(Cells(i + 4, 15)) = Cells(i + 4, 20): 'EtLo(Cells(i + 4, 15)) = Cells(i + 4, 21) Next i
For i = 1 To Nn Npa = 0: Nek = 0: Nce = 0: Nlo = 0 Otkl(i) = ((m(i, 11) - Z(i)) + (P(i) - m(i, 12))) For j = 1 To 10 If j < 6 And PaIp(m(i, j)) = 1 Then Npa = Npa + 1: If j > 5 And PaIp(m(i, j)) = 1 Then Npa = Npa - 1 If j < 6 And EkIn(m(i, j)) = 1 Then Nek = Nek + 1: If j > 5 And EkIn(m(i, j)) = 1 Then Nek = Nek - 1 If j < 6 And CeIt(m(i, j)) = 1 Then Nce = Nce + 1: If j > 5 And CeIt(m(i, j)) = 1 Then Nce = Nce - 1 If j < 6 And EtLo(m(i, j)) = 1 Then Nlo = Nlo + 1: If j > 5 And EtLo(m(i, j)) = 1 Then Nlo = Nlo - 1 Next j Del(i, 1) = 1000 * Npa / 10: Del(i, 2) = 1000 * Nek / 10 Del(i, 3) = 1000 * Nce / 10: Del(i, 4) = 1000 * Nlo / 10 Next i
For i = 1 To Nn 'Cells(i, 25) = Del(i, 1): Cells(i, 26) = Del(i, 2): Cells(i, 27) = Del(i, 3): Cells(i, 28) = Del(i, 4) 'Cells(i, 24) = Otkl(i) Next i ' посчитаем разность если бы распределение было бы равномерным For i = 1 To Nig Sts = Sts + b1(i) + b2(i) Next i Sts = Sts / Nig For i = 1 To Nig Zkp(i) = (Sts + (Sts * (X(i) - 2200) / 1000)) / 2: Pkp(i) = Sts - Zkp(i) Next i
For i = 1 To Nig Cells(c(i) + 4, 18) = c(i) Cells(c(i) + 4, 19) = Familia(i) Cells(c(i) + 4, 20) = X(i): Cells(c(i) + 4, 21) = b1(i) Cells(c(i) + 4, 22) = b2(i) Cells(c(i) + 4, 23) = Zkp(i) Cells(c(i) + 4, 24) = Pkp(i) Next i
End Sub
Полозов, А.А. Система рейтинга в игровых видах спорта и единоборствах: Монография. Екатеринбург: Изд-во УГТУ-УПИ, 1995. 110 с. Полозов, А.А. Рейтинг в спорте: вчера, сегодня, завтра / А.А.Полозов. – М.:Советский спорт, 2007 – 316с. www.polozov.nemi-ekb.ru
|