Генерация четного количества трасс в левой и правой полосах для гонщиков

Question

Я работаю над таблицей для гонки типа дерби в мыльной коробке, которая может автоматически генерировать равномерное количество трасс в левой и правой линии на гонщика.Это также будет рандомизировать, кто участвует в гонке против кого.В настоящее время у меня есть 6 плавок и кнопка над каждым.Он извлекает из списка гонщиков со случайно сгенерированным числом в ячейке рядом с ним, используя метод, показанный здесь: https://www.extendoffice.com/documents/excel/4591-excel-random-selection-no-duplicates.html

Вот как выглядит лист.
Столбец «НЕ ПРИКАСАТЬСЯ» затем копируется на другой лист и помещается в каждый нагрев при нажатии кнопки выше этого нагревания.Лист нагрева выглядит следующим образом:

Каждый раз, когда нажимается кнопка нагрева, он копирует и вставляет из листа «Randomizer», а поскольку лист обновляется каждый раз, он будет случайным образом отображаться на каждой кнопке.нажмите кнопку.Следующий макрос запускается при нажатии кнопки обогрева.

Sub btnHeat1_Click()
  On Error Resume Next
  Dim xRg As Range
  Dim WS As Worksheet
  Dim Shp As Shape
  Set xRg = Application.Selection
  Set WS = ActiveSheet
  Set Shp = WS.Shapes("btnHeat1")
  Worksheets("Randomizer").Range("E4:E62").Copy
  Worksheets("The Race is On").Range("F4:F62").PasteSpecial xlPasteValues
  xRg.Select
  Shp.Visible = False
End Sub

Мне нужно улучшить рандомизатор, чтобы у каждого гонщика было одинаковое количество трасс в левой и правой полосах движения (по 3 раза с каждой стороны).Я не знаю, как это сделать, и я не смог найти в Интернете ни одного примера подобной ситуации (плавки в гонках, игры в гольф и т. Д.).Я думал о записи правой и левой полос при каждом нажатии кнопки обогрева, но не знал, как реализовать это в существующем рандомизаторе.Или все плавки должны быть сгенерированы одновременно, и правая и левая дорожки могут представлять 0 и 1. В уравнении рандомизатора.

Есть какие-либо предложения о том, как этого добиться?Спасибо!

Answer 1

Таким образом, следующий код должен служить основой для того, чего вы пытаетесь достичь - обратите внимание, что в настоящее время это генерирует плавки в активном листе с участниками, назначенными численно;потребуется дополнительная работа для адаптации к вашему рабочему листу

, он создает массив участников, а затем последовательно «сдвигает» элементы массива на рассчитанную величину, так что в течение всего периода нагрева должен отображаться каждый элемент.в равной степени в первой половине и во второй половине каждого «теплового» массива.Затем массив делится пополам и каждая половина рандомизируется.

Следовательно, он должен генерировать случайное соединение, где каждый участник в равной степени находится на правой или левой полосе, как указано в задаче ...

Sub GenerateHeatData()
    Dim Contestants As Long: Contestants = 16
    Dim Heats As Long: Heats = 6
    Dim CycleLength As Long: CycleLength = WorksheetFunction.Ceiling(Contestants / Heats, 1)

    Dim i As Long, j As Long, Arr() As Variant, Left() As Variant, Right() As Variant

    Dim BaseArray() As Variant
    ReDim BaseArray(Contestants - 1)
    For i = 0 To UBound(BaseArray)
        BaseArray(i) = i + 1
    Next i

    Dim BaseHeatArray() As Variant
    ReDim BaseHeatArray(Heats - 1)
    For i = 0 To UBound(BaseHeatArray)
        BaseHeatArray(i) = i + 1
    Next i

    Call RandomiseArray(BaseHeatArray)

    For i = 0 To Heats - 1
        Arr = RightShiftArray(BaseArray, CycleLength * CLng(BaseHeatArray(i)))
        Left = ExtractArray(Arr, 0, WorksheetFunction.Ceiling(UBound(Arr) / 2, 1))
        Right = ExtractArray(Arr, UBound(Left) + 1, UBound(Arr) - UBound(Left))
        Call RandomiseArray(Left)
        Call RandomiseArray(Right)
        For j = 0 To UBound(Left)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * i + 1) = CLng(Left(j))
        Next j
        For j = 0 To UBound(Right)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * i + 2) = CLng(Right(j))
        Next j
    Next i
End Sub

Function RightShiftArray(InArray() As Variant, Shift As Long) As Variant()
    Shift = Shift Mod (UBound(InArray) + 1)
    If Shift < 1 Then Shift = Shift + UBound(InArray)

    Dim TempArr() As Variant: ReDim TempArr(Shift - 1)
    Dim i As Long, Arr() As Variant

    ReDim Arr(LBound(InArray) To UBound(InArray))
    For i = LBound(InArray) To UBound(InArray)
        Arr(i) = InArray(i)
    Next i

    For i = 0 To UBound(TempArr)
        TempArr(i) = Arr(UBound(Arr) - Shift + i + 1)
    Next i
    For i = 0 To UBound(Arr) - Shift
        Arr(UBound(Arr) - i) = Arr(UBound(Arr) - i - Shift)
    Next i
    For i = 0 To UBound(TempArr)
        Arr(i) = TempArr(i)
    Next i

    RightShiftArray = Arr
End Function

Function RandomiseArray(Arr() As Variant)
    Dim i As Long, j As Long
    Dim Temp As Variant

    Randomize
    For i = LBound(Arr) To UBound(Arr)
        j = CLng(((UBound(Arr) - i) * Rnd) + i)
        If i <> j Then
            Temp = Arr(i)
            Arr(i) = Arr(j)
            Arr(j) = Temp
        End If
    Next i
End Function

Function ExtractArray(InArray() As Variant, First As Long, Length As Long) As Variant()
    On Error Resume Next
    Dim i As Long, Arr() As Variant
    ReDim Arr(Length - 1)
    For i = LBound(Arr) To UBound(Arr)
        Arr(i) = InArray(First + i)
    Next i
    ExtractArray = Arr
End Function

* РЕДАКТИРОВАТЬ - Добавитьзеркальные задания *

Sub GenerateHeatData()
    Dim i As Long, j As Long, Left() As Variant, Right() As Variant

    Dim Contestants As Long: Contestants = 10
    Dim Heats As Long: Heats = 6 ' Heats should be even
    Dim BaseArray() As Variant: ReDim BaseArray(Contestants - 1)
    For i = 0 To UBound(BaseArray)
        BaseArray(i) = i + 1
    Next i

    For i = 0 To Heats / 2 - 1
        Call RandomiseArray(BaseArray)
        Left = ExtractArray(BaseArray, 0, WorksheetFunction.Ceiling(UBound(BaseArray) / 2, 1))
        Right = ExtractArray(BaseArray, UBound(Left) + 1, UBound(BaseArray) - UBound(Left))

        Call RandomiseArray(Left)
        For j = 0 To UBound(Left)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * i + 1) = CLng(Left(j))
        Next j
        Call RandomiseArray(Left)
        For j = 0 To UBound(Left)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * (i + Heats / 2) + 2) = CLng(Left(j))
        Next j

        Call RandomiseArray(Right)
        For j = 0 To UBound(Right)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * i + 2) = CLng(Right(j))
        Next j
        Call RandomiseArray(Right)
        For j = 0 To UBound(Right)
            ThisWorkbook.ActiveSheet.Cells(j + 1, 3 * (i + Heats / 2) + 1) = CLng(Right(j))
        Next j
    Next i
End Sub

Function RandomiseArray(Arr() As Variant)
    Dim i As Long, j As Long
    Dim Temp As Variant

    Randomize
    For i = LBound(Arr) To UBound(Arr)
        j = CLng(((UBound(Arr) - i) * Rnd) + i)
        If i <> j Then
            Temp = Arr(i)
            Arr(i) = Arr(j)
            Arr(j) = Temp
        End If
    Next i
End Function

Function ExtractArray(InArray() As Variant, First As Long, Length As Long) As Variant()
    On Error Resume Next
    Dim i As Long, Arr() As Variant
    ReDim Arr(Length - 1)
    For i = LBound(Arr) To UBound(Arr)
        Arr(i) = InArray(First + i)
    Next i
    ExtractArray = Arr
End Function