Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Заполнение матрицы 10 на 10 случайными числами без повторений по столбцам и строкам, Для жеребьевки рассадки игроков
 
#1
26.03.2021 15:46:12
Всем привет!

Есть 10 игроков (строки), которые проводят 10 игр (столбцы). В каждой игре игроки получают неповторяющийся номер от 1 до 10. Нужно провести жеребьевку, чтобы в течение 10 игр игрок не получил повторно один и тот же номер.
Задача: сделать случайную жеребьевку (рассадку) 10 участников на 10 игр так, чтобы не было повторений внутри 1 игры (столбец) и относительно 1 игрока (строка).
По сути задача сводится к заполнению матрицы 10 на 10 случайными числами без повторений по столбцам и строкам.
Как сделать внутри столбца, я понял (через Rnd и потом Rank по столбцу), а вот как учесть уникальность по строке, не допру...
Буду признателен за конкретные примеры реализации задачи.
Код
For i = 1 To 10
      myRange.Cells(i, 1) = Rnd
Next
For i = 1 To 10
      myRange.Cells(i, 2) = WorksheetFunction.Rank_Eq(myRange.Cells(i, 1), myRange.Range(Cells(1, 1), Cells(10, 1)))
Next
 
 
 
#2
26.03.2021 16:26:30
Интересная задача.
Этот макрос в диапазон, начинающийся с активной ячейки, выведет массив 10х10. С уникальными значениями в строках и столбцах.
Есть недостаток, не все значения удаётся подобрать.
Код
Sub Fill1010()
    Dim arr As Variant
    arr = GetArr()
    
    ActiveCell.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr() As Variant
    
    Dim arr As Variant
    ReDim arr(1 To 10, 1 To 10)
    Dim dic As Object
    
    Dim y As Byte
    Dim x As Byte
    Dim u As Integer
    Dim h As Byte
    For y = 1 To 10
    For x = 1 To 10
        Set dic = CreateObject("Scripting.Dictionary")
        For u = 1 To 10
            dic.Item(u) = 0
        Next
        For u = 1 To 10
            If dic.Exists(arr(y, u)) Then dic.Remove arr(y, u)
        Next
        For u = 1 To 10
            If dic.Exists(arr(u, x)) Then dic.Remove arr(u, x)
        Next
        u = Rnd * (dic.Count - 1)
        If dic.Count > 0 Then
            arr(y, x) = dic.Keys()(u)
        End If
    Next
    Next
    
    GetArr = arr
End Function
 
 
 
#3
26.03.2021 16:41:35
Так без пропусков.
Код
Sub Fill1010()
    Dim arr As Variant
    arr = GetArr2()
    
    ActiveCell.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr2() As Variant
    Randomize
    
    Dim arr As Variant
    ReDim arr(1 To 10, 1 To 10)
    Dim brr As Variant
    ReDim brr(1 To 10, 1 To 1)
    Dim crr As Variant
    ReDim crr(1 To 10, 1 To 1)
    
    Dim y As Byte
    Dim x As Byte
    Dim u As Integer
    Dim h As Byte
    For y = 1 To 10
    For x = 1 To 10
        arr(y, x) = y + x - 1
        If arr(y, x) > 10 Then arr(y, x) = arr(y, x) - 10
    Next
        brr(y, 1) = Rnd
        crr(y, 1) = Rnd
    Next
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        .Cells(1, 2).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1:A10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A1:K10")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        arr = .Range("B1:K10")
        arr = Application.Transpose(arr)
        
        .Cells(1, 2).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        .Cells(1, 1).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
    
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1:A10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A1:K10")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        arr = .Range("B1:K10")
    
    End With
    wb.Close False
    
    GetArr2 = arr
End Function
Изменено: МатросНаЗебре - 26.03.2021 17:44:59 (GetArr2 = arr)
 
 
 
#4
26.03.2021 17:34:22
Спасибо огромное! Все работает.
Только в конце функцию нужно подправить: GetArr2 = arr должно быть.
Скажите, а сложно ли добавить разбивку повтора соседей? То есть, чтобы при жеребьевке проверять не находились ли уже номера рядом ранее и если да, то предложить другой вариант. Эта реализация была бы конечно космос :)
 
 
 
#5
26.03.2021 18:21:14
Для коллекции: Случайные числа без повторов
 
 
 
#6
26.03.2021 22:31:43
Цитата
Александр написал:
Эта реализация была бы конечно космос
Ну раз речь про фантастические сценарии...
Можно сгенерировать все варианты, и потом из них случайным образом выбирать нужный.
Запустите этот макрос, подождите 10е+90 лет.
При желании можно будет формулами наложить дополнительные ограничения, вроде повтора соседей.
Код
Sub СгенерироватьРеализации()
    Dim sh As Worksheet
    On Error Resume Next
        Set sh = ThisWorkbook.Sheets("allvar")
    On Error GoTo 0
    If sh Is Nothing Then
        ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "allvar"
    End If
    Dim yOut1 As Long
    yOut1 = 1

    Dim a As Variant
    ReDim a(1 To 10, 1 To 10)
    Dim y As Byte
    Dim x1 As Byte
    Dim x2 As Byte
    Dim f As Boolean
    
    Dim a11 As Variant: Dim a12 As Variant: Dim a13 As Variant: Dim a14 As Variant: Dim a15 As Variant: Dim a16 As Variant: Dim a17 As Variant: Dim a18 As Variant: Dim a19 As Variant: Dim a10 As Variant
    Dim a21 As Variant: Dim a22 As Variant: Dim a23 As Variant: Dim a24 As Variant: Dim a25 As Variant: Dim a26 As Variant: Dim a27 As Variant: Dim a28 As Variant: Dim a29 As Variant: Dim a20 As Variant
    Dim a31 As Variant: Dim a32 As Variant: Dim a33 As Variant: Dim a34 As Variant: Dim a35 As Variant: Dim a36 As Variant: Dim a37 As Variant: Dim a38 As Variant: Dim a39 As Variant: Dim a30 As Variant
    Dim a41 As Variant: Dim a42 As Variant: Dim a43 As Variant: Dim a44 As Variant: Dim a45 As Variant: Dim a46 As Variant: Dim a47 As Variant: Dim a48 As Variant: Dim a49 As Variant: Dim a40 As Variant
    Dim a51 As Variant: Dim a52 As Variant: Dim a53 As Variant: Dim a54 As Variant: Dim a55 As Variant: Dim a56 As Variant: Dim a57 As Variant: Dim a58 As Variant: Dim a59 As Variant: Dim a50 As Variant
    Dim a61 As Variant: Dim a62 As Variant: Dim a63 As Variant: Dim a64 As Variant: Dim a65 As Variant: Dim a66 As Variant: Dim a67 As Variant: Dim a68 As Variant: Dim a69 As Variant: Dim a60 As Variant
    Dim a71 As Variant: Dim a72 As Variant: Dim a73 As Variant: Dim a74 As Variant: Dim a75 As Variant: Dim a76 As Variant: Dim a77 As Variant: Dim a78 As Variant: Dim a79 As Variant: Dim a70 As Variant
    Dim a81 As Variant: Dim a82 As Variant: Dim a83 As Variant: Dim a84 As Variant: Dim a85 As Variant: Dim a86 As Variant: Dim a87 As Variant: Dim a88 As Variant: Dim a89 As Variant: Dim a80 As Variant
    Dim a91 As Variant: Dim a92 As Variant: Dim a93 As Variant: Dim a94 As Variant: Dim a95 As Variant: Dim a96 As Variant: Dim a97 As Variant: Dim a98 As Variant: Dim a99 As Variant: Dim a90 As Variant
    Dim a01 As Variant: Dim a02 As Variant: Dim a03 As Variant: Dim a04 As Variant: Dim a05 As Variant: Dim a06 As Variant: Dim a07 As Variant: Dim a08 As Variant: Dim a09 As Variant: Dim a00 As Variant
    
    
    For a11 = 1 To 10: For a12 = 1 To 10: For a13 = 1 To 10: For a14 = 1 To 10: For a15 = 1 To 10: For a16 = 1 To 10: For a17 = 1 To 10: For a18 = 1 To 10: For a19 = 1 To 10: For a10 = 1 To 10
    For a21 = 1 To 10: For a22 = 1 To 10: For a23 = 1 To 10: For a24 = 1 To 10: For a25 = 1 To 10: For a26 = 1 To 10: For a27 = 1 To 10: For a28 = 1 To 10: For a29 = 1 To 10: For a20 = 1 To 10
    For a31 = 1 To 10: For a32 = 1 To 10: For a33 = 1 To 10: For a34 = 1 To 10: For a35 = 1 To 10: For a36 = 1 To 10: For a37 = 1 To 10: For a38 = 1 To 10: For a39 = 1 To 10: For a30 = 1 To 10
    For a41 = 1 To 10: For a42 = 1 To 10: For a43 = 1 To 10: For a44 = 1 To 10: For a45 = 1 To 10: For a46 = 1 To 10: For a47 = 1 To 10: For a48 = 1 To 10: For a49 = 1 To 10: For a40 = 1 To 10
    For a51 = 1 To 10: For a52 = 1 To 10: For a53 = 1 To 10: For a54 = 1 To 10: For a55 = 1 To 10: For a56 = 1 To 10: For a57 = 1 To 10: For a58 = 1 To 10: For a59 = 1 To 10: For a50 = 1 To 10
    For a61 = 1 To 10: For a62 = 1 To 10: For a63 = 1 To 10: For a64 = 1 To 10: For a65 = 1 To 10: For a66 = 1 To 10: For a67 = 1 To 10: For a68 = 1 To 10: For a69 = 1 To 10: For a60 = 1 To 10
    For a71 = 1 To 10: For a72 = 1 To 10: For a73 = 1 To 10: For a74 = 1 To 10: For a75 = 1 To 10: For a76 = 1 To 10: For a77 = 1 To 10: For a78 = 1 To 10: For a79 = 1 To 10: For a70 = 1 To 10
    For a81 = 1 To 10: For a82 = 1 To 10: For a83 = 1 To 10: For a84 = 1 To 10: For a85 = 1 To 10: For a86 = 1 To 10: For a87 = 1 To 10: For a88 = 1 To 10: For a89 = 1 To 10: For a80 = 1 To 10
    For a91 = 1 To 10: For a92 = 1 To 10: For a93 = 1 To 10: For a94 = 1 To 10: For a95 = 1 To 10: For a96 = 1 To 10: For a97 = 1 To 10: For a98 = 1 To 10: For a99 = 1 To 10: For a90 = 1 To 10
    For a01 = 1 To 10: For a02 = 1 To 10: For a03 = 1 To 10: For a04 = 1 To 10: For a05 = 1 To 10: For a06 = 1 To 10: For a07 = 1 To 10: For a08 = 1 To 10: For a09 = 1 To 10: For a00 = 1 To 10
        a(1, 1) = a11: a(1, 2) = a12: a(1, 3) = a13: a(1, 4) = a14: a(1, 5) = a15: a(1, 6) = a16: a(1, 7) = a17: a(1, 8) = a18: a(1, 9) = a19: a(1, 10) = a10
        a(2, 1) = a21: a(2, 2) = a22: a(2, 3) = a23: a(2, 4) = a24: a(2, 5) = a25: a(2, 6) = a26: a(2, 7) = a27: a(2, 8) = a28: a(2, 9) = a29: a(2, 10) = a20
        a(3, 1) = a31: a(3, 2) = a32: a(3, 3) = a33: a(3, 4) = a34: a(3, 5) = a35: a(3, 6) = a36: a(3, 7) = a37: a(3, 8) = a38: a(3, 9) = a39: a(3, 10) = a30
        a(4, 1) = a41: a(4, 2) = a42: a(4, 3) = a43: a(4, 4) = a44: a(4, 5) = a45: a(4, 6) = a46: a(4, 7) = a47: a(4, 8) = a48: a(4, 9) = a49: a(4, 10) = a40
        a(5, 1) = a51: a(5, 2) = a52: a(5, 3) = a53: a(5, 4) = a54: a(5, 5) = a55: a(5, 6) = a56: a(5, 7) = a57: a(5, 8) = a58: a(5, 9) = a59: a(5, 10) = a50
        a(6, 1) = a61: a(6, 2) = a62: a(6, 3) = a63: a(6, 4) = a64: a(6, 5) = a65: a(6, 6) = a66: a(6, 7) = a67: a(6, 8) = a68: a(6, 9) = a69: a(6, 10) = a60
        a(7, 1) = a71: a(7, 2) = a72: a(7, 3) = a73: a(7, 4) = a74: a(7, 5) = a75: a(7, 6) = a76: a(7, 7) = a77: a(7, 8) = a78: a(7, 9) = a79: a(7, 10) = a70
        a(8, 1) = a81: a(8, 2) = a82: a(8, 3) = a83: a(8, 4) = a84: a(8, 5) = a85: a(8, 6) = a86: a(8, 7) = a87: a(8, 8) = a88: a(8, 9) = a89: a(8, 10) = a80
        a(9, 1) = a91: a(9, 2) = a92: a(9, 3) = a93: a(9, 4) = a94: a(9, 5) = a95: a(9, 6) = a96: a(9, 7) = a97: a(9, 8) = a98: a(9, 9) = a99: a(9, 10) = a90
        a(10, 1) = a01: a(10, 2) = a02: a(10, 3) = a03: a(10, 4) = a04: a(10, 5) = a05: a(10, 6) = a06: a(10, 7) = a07: a(10, 8) = a08: a(10, 9) = a09: a(10, 10) = a00
        
        f = True
        For y = 1 To 10
            For x1 = 1 To 10
            For x2 = x1 + 1 To 10
                If a(y, x1) = a(y, x2) Then
                    f = False
                    y = 11
                    x1 = 11
                    x2 = 11
                End If
            Next
            Next
        Next
        If f Then
        For y = 1 To 10
            For x1 = 1 To 10
            For x2 = x1 + 1 To 10
                If a(x1, y) = a(x2, y) Then
                    f = False
                    y = 11
                    x1 = 11
                    x2 = 11
                End If
            Next
            Next
        Next
        End If
        
        If f Then
            sh.Cells(yOut1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
            yOut1 = yOut1 + 10
        End If
        
        
        DoEvents
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
    
End Sub
PS Всё-таки ж скоро 1 апреля )
 
 
 
#7
26.03.2021 22:52:59
похоже на код написанный искусственным интеллектом
a можно так:
Код
Sub Matrix(Cnt&, TopLeftCell As Range)
  Dim r, a, n, i&, j&, v&, p&
  ReDim r(1 To 2, 1 To Cnt), n(1 To 2, 1 To 2 * Cnt), a(1 To Cnt, 1 To Cnt)
  Randomize
  For i = 1 To 2
    For j = 1 To Cnt: r(i, j) = Rnd: Next
  Next
  For i = 1 To Cnt
    For j = 1 To Cnt
      If r(1, i) <= r(1, j) Then n(1, i) = n(1, i) + 1
      If r(2, i) <= r(2, j) Then n(2, i) = n(2, i) + 1
    Next
    n(1, i + Cnt) = n(1, i): If n(2, i) = n(1, 1) Then p = i
  Next
  v = n(2, 1): n(2, 1) = n(2, p): n(2, p) = v
  For i = 1 To Cnt
    For j = n(2, i) To n(2, i) - 1 + Cnt: a(i, 1 + j - n(2, i)) = n(1, j)
    Next
  Next
  TopLeftCell.Resize(UBound(a), UBound(a)) = a
End Sub
где
Cnt - размер матрицы
TopLeftCell - верхняя левая ячейка для вывода результатов
Изменено: Ігор Гончаренко - 27.03.2021 01:40:52
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#8
27.03.2021 08:47:04
Цитата
Ігор Гончаренко похоже на код написанный искусственным интеллектом :D
У меня немного поскромнее но условия поставленные в задании выполняются
Код
Sub dfhs()
Dim XX, VTp1, nT, kT
ReDim VTp1(1 To 10, 1 To 10)
XX = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
For i = 1 To 10
nT = XX(LBound(XX))
kT = XX(UBound(XX))
For j = 2 To 10
VTp1(i, j) = XX(j - 2)
XX(j - 2) = XX(j - 1)
Next j
VTp1(i, 1) = kT
XX(UBound(XX)) = nT
Next i
Range("A1").Resize(UBound(VTp1, 1), UBound(VTp1, 2)) = VTp1
End Sub
Изменено: Евгений Смирнов - 27.03.2021 09:13:13
 
 
 
#9
27.03.2021 09:36:04
Цитата
Евгений Смирнов написал:
но условия поставленные в задании выполняются
Не полностью
Цитата
Александр написал:
Задача: сделать случайную жеребьевку
У вас статика :)
Ещё вариант.
 
 
 
#10
27.03.2021 09:43:34
А у меня не получается  :cry:
=AGGREGATE(15;6;ROW($1:$10)/ISNA(MATCH(ROW($1:$10);B$1:B1;))/ISNA(MATCH(ROW($1:$10);$A2:A2;));RANDBETWEEN(1;SUMPRODUCT(--((COUNTIF($A2:A2;ROW($1:$10))+COUNTIF(B$1:B1;ROW($1:$10)))=0)))) и причины то понятны, но .....
По вопросам из тем форума, личку не читаю.
 
 
 
#11
27.03.2021 09:58:32
Цитата
БМВ написал:
но .....
Привет, Михаил.
Следовательно нужно менять подход к решению задачи. Всего возможных вариантов n! * n. Следовательно, варианты можно пронумеровать. Если это сделать как в подходе генерации сочетаний в лексикографическом порядке, то можно решить и обратную задачу - по номеру порядка восстановить соответствующую ему структуру. Естественно, можно такой номер брать случайным образом.
 
 
 
#12
27.03.2021 10:38:37
Цитата
Евгений Смирнов написал:
но условия поставленные в задании выполняются
ага, каждый новый пересчет показывает новую таблицу с совершенно случайно расположенными в ней числами
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#13
27.03.2021 10:41:34
Цитата
Андрей VG написал:
Следовательно нужно менять подход к решению задачи.
Андрей, привет. Для формульных вариантов решений не так много, и судя по всему нужно не только убирать уже использованные, но и прогнозировать возможные. Типа занимать те, которые не потребуются для дальнейших столбцов, тем самым снизив вероятность нехватки вариантов, но, снова но, это опять не гарантирует результат :-(
По вопросам из тем форума, личку не читаю.
 
 
 
#14
27.03.2021 12:54:54
Цитата
Ігор Гончаренко ага, каждый новый пересчет показывает новую таблицу с совершенно случайно расположенными в ней числами
А теперь подходит
Код
Sub Matrix1(): Dim XX, vTp1, nT&, i&, j&, kElem&, Rnd1&, Col As New Collection
kElem = 10: ReDim vTp1(1 To kElem, 1 To kElem)
ReDim XX(1 To kElem): On Error Resume Next
    Do While Col.Count < kElem
Rnd1 = Round(Rnd * kElem): Err = 0
If Rnd1 > 0 Then Col.Add Rnd1, CStr(Rnd1): If Err = 0 Then i = i + 1: XX(i) = Col(i)
    Loop: On Error GoTo 0
For i = 1 To kElem
nT = XX(1): vTp1(i, 1) = XX(kElem)
    For j = 2 To kElem
        vTp1(i, j) = XX(j - 1): XX(j - 1) = XX(j)
    Next j: XX(kElem) = nT
Next i
Range("A1").Resize(kElem, kElem) = vTp1
End Sub
Изменено: Евгений Смирнов - 31.03.2021 17:13:38
 
 
 
Страницы: 1
Наверх