Исходный код
Option Explicit 'об¤зательное объ¤вление переменных
Type accountTeam
Name As String ' »м¤
Score As Integer ' «абито
Missing As Integer ' ѕропущено
Winn As Integer ' ѕобед
Difer As Integer ' –азница=«абито-ѕропущено
Points As Integer 'забито+2 балла за каждую победу
End Type
Public Const n = 24 'всего команд
Public accountTeamTable() As accountTeam '—водна¤ таблица
Sub Solution()
Dim i, j, k, l, x, p, q, sumWin1, sumWin2, m, start, random1, random2, toRight, counter, rowCount As Integer
Dim s As String
ReDim accountTeamTable(1 To n) 'указываем размер массива
For i = 1 To n
accountTeamTable(i).Name = Worksheets(2).Cells(i, 1).Value 'заполним
Next i
Worksheets(1).Activate
Worksheets(1).Cells.Clear
With Worksheets(1) '-------------рисуем таблицы
counter = 0
rowCount = 2
toRight = 0
s = "ƒома"
For i = 1 To 2
For j = 1 To 2
For k = 1 To n / 2
.Cells(rowCount, toRight + 1).Value = s
.Cells(rowCount + k + 1, 1 + toRight).Value = accountTeamTable(k + counter).Name
.Cells(rowCount + 1, k + 1 + toRight).Value = accountTeamTable(k + counter).Name
Next k
toRight = 14
s = "¬ гост¤х"
Range(Cells(rowCount + 1, 1), Cells(rowCount + 13, 13)).Borders.LineStyle = xlContinuous 'границы
Range(Cells(rowCount + 1, 1 + toRight), Cells(rowCount + 13, 13 + toRight)).Borders.LineStyle = xlContinuous 'границы
Next j
counter = 12
toRight = 0
rowCount = rowCount + 15
s = "ƒома"
Next i
counter = 0 '-----------------заполн¤ем счет
rowCount = 2
toRight = 0
For l = 1 To 2
For k = 1 To 2
For i = 1 To n / 2
For j = 1 To n / 2
random1 = getRandom(10)
random2 = getRandom(10)
.Cells(i + rowCount + 1, j + 1 + toRight).Value = Str(random1) + ":" + Str(random2)
If i <> j Then
.Cells(j + rowCount + 1, i + 1 + toRight).Value = Str(random2) + ":" + Str(random1)
End If
If .Cells(i + rowCount + 1, 1 + toRight).Value = .Cells(rowCount + 1, j + 1 + toRight).Value Then
.Cells(i + rowCount + 1, j + 1 + toRight).Clear
.Cells(i + rowCount + 1, j + 1 + toRight).Value = "---"
End If
s = .Cells(i + rowCount + 1, j + 1 + toRight).Value
accountTeamTable(j + counter).Score = parseAccount(s, 1) + accountTeamTable(j + counter).Score
accountTeamTable(j + counter).Missing = parseAccount(s, 2) + accountTeamTable(j + counter).Missing
accountTeamTable(j + counter).Difer = Abs(accountTeamTable(j + counter).Score - accountTeamTable(j + counter).Missing)
accountTeamTable(j + counter).Points = accountTeamTable(j + counter).Points + parseAccount(s, 1)
Next j
Next i
toRight = 14
Next k
counter = 12
toRight = 0
rowCount = rowCount + 15
Next l
counter = 0 '-----------------считаем победы
rowCount = 3
toRight = 0
For l = 1 To 2
For k = 1 To 2
For j = 1 To n / 2
For i = 1 To n / 2
s = .Cells(j + rowCount, i + 1 + toRight).Value
If parseAccount(s, 1) > parseAccount(s, 2) Then
accountTeamTable(j + counter).Winn = accountTeamTable(j + counter).Winn + 1
accountTeamTable(j + counter).Points = accountTeamTable(j + counter).Points + 3 'число балов
End If
If parseAccount(s, 1) = parseAccount(s, 2) Then 'ничь¤
accountTeamTable(j + counter).Points = accountTeamTable(j + counter).Points + 1
End If
Next i
Next j
toRight = toRight + 14
Next k
toRight = 0
rowCount = rowCount + 15
counter = 12
Next l 'сортируем по количеству очков 'определ¤ем победителей
Call sortInsrt(accountTeamTable, n / 2, 0)
Call defWinner(accountTeamTable, n / 2, 0)
Call sortInsrt(accountTeamTable, n / 2, 12)
Call defWinner(accountTeamTable, n / 2, 12)
End With
Worksheets(3).Activate
With Worksheets(3)
p = 16
x = 2
toRight = 0
rowCount = 1
q = 2
For l = 1 To 3 '1/(p/2) финала
ReDim accountTeamTable(1 To p)
With Worksheets(2)
For i = 1 To p
accountTeamTable(i).Name = .Cells(i, q).Value 'заполн¤ем
Next i
End With
.Cells(rowCount, 1 + toRight).Value = "1/" + Str(p / 2) + " финала"
m = p
For i = 1 To p / 2
.Cells(rowCount + i + 1, 1 + toRight).Value = accountTeamTable(i).Name
.Cells(rowCount + i + 1, 3 + toRight).Value = accountTeamTable(m).Name
sumWin1 = 0
sumWin2 = 0
Call nWinn(sumWin1, sumWin2, x) 'до x побед
If sumWin1 > sumWin2 Then
Worksheets(2).Cells(i, 1 + q).Value = accountTeamTable(i).Name
ElseIf sumWin1 < sumWin2 Then
Worksheets(2).Cells(i, 1 + q).Value = accountTeamTable(m).Name
End If
.Cells(rowCount + i + 1, 2 + toRight).Value = Str(sumWin1) + ":" + Str(sumWin2)
m = m - 1
Next i
p = p / 2 ' количество команд
x = 3 'до скольки побед
toRight = toRight + 4 'смещение вправо
q = q + 1 'столбец со второго листа
Next l
.Cells(rowCount, 13).Value = "‘инал" '‘инал
For i = 1 To 2
accountTeamTable(i).Name = Worksheets(2).Cells(i, 5).Value 'заполним
Next i
.Cells(rowCount + 2, 13).Value = accountTeamTable(1).Name
.Cells(rowCount + 2, 15).Value = accountTeamTable(2).Name
sumWin1 = 0
sumWin2 = 0
Call nWinn(sumWin1, sumWin2, 4) 'до 4х побед
.Cells(rowCount + 2, 14).Value = Str(sumWin1) + ":" + Str(sumWin2)
MsgBox "ѕобедитель: " + .Cells(rowCount + 2, 13).Value
End With
End Sub
Public Sub nWinn(ByRef sumWin1, ByRef sumWin2, ByVal n) 'сумма первой команды, второй команды, число побед
Dim random1, random2 As Integer
Do While (True)
random1 = getRandom(10)
random2 = getRandom(10)
If random1 > random2 Then
sumWin1 = sumWin1 + 1
ElseIf random1 < random2 Then
sumWin2 = sumWin2 + 1
End If
If Abs(sumWin1 - sumWin2) = n Then
Exit Do
End If
Loop
End Sub
Public Sub defWinner(ByRef arr() As accountTeam, ByVal n As Integer, start As Integer)
Dim i, j As Integer
Dim rowCount As Integer
rowCount = 0
If start <> 0 Then
rowCount = 8
End If
For i = 1 To 8
For j = 1 To 8
If arr(i + start).Points <> arr(j + start).Points Then
Worksheets(2).Cells(i + rowCount, 2).Value = arr(i + start).Name
ElseIf arr(i + start).Points = arr(j + start).Points Then
If arr(i + start).Difer > arr(j + start).Difer Then
Worksheets(2).Cells(i + rowCount, 2).Value = arr(i + start).Name
ElseIf arr(i + start).Difer = arr(j + start).Difer Then
If arr(i + start).Winn > arr(j + start).Winn Then
Worksheets(2).Cells(i + rowCount, 2).Value = arr(i + start).Name
End If
End If
End If
Next j
Next i
End Sub
Public Sub sortInsrt(ByRef arr() As accountTeam, ByVal n As Integer, start As Integer) 'сортировка вставками start-откуда начинать сортировать
Dim i, j, k As Integer
Dim tmp As accountTeam
n = n
i = 2
Do
j = 1
Do
If arr(i + start).Points >= arr(j + start).Points Then
k = i
tmp = arr(i + start)
Do
arr(k + start) = arr(k - 1 + start)
k = k - 1
Loop Until Not k > j
arr(j + start) = tmp
j = i
Else
j = j + 1
End If
Loop Until Not j < i
i = i + 1
Loop Until Not i <= n
End Sub
Function getRandom(x As Integer)
getRandom = Int(0 + Rnd * x)
End Function
Function parseAccount(s As String, x As Integer) As Integer ' передаем строку и число. 1- забито, 2 -пропущенно
Dim a() As String
If s = "---" Then
parseAccount = 0
Else
a() = Split(s, ":")
Select Case x
Case 1 'забито
parseAccount = a(0)
Case 2 'пропущенно
parseAccount = a(1)
End Select
End If
End Function