为赛车手在左右车道上产生均匀的跑步次数

Question

我正在为肥皂盒德比类型的比赛制作电子表格，该表格可以自动为每位赛车手在左右线生成均匀的跑步次数。它还将随机化谁与谁比赛。目前，我有 6 个加热装置，每个加热装置上方都有一个按钮。它使用此处显示的方法从旁边的单元格中随机生成数字的赛车手列表中提取：https://www.extendoffice.com/documents/excel/4591-excel-random-selection-no-duplicates.html

这就是工作表的样子。
[![img][1]][1] 然后，当在该热量上方按下按钮时，将“不要触摸”列复制到另一张纸上并放置在每个热量中。散热片如下所示：![img][2]

每次点击加热按钮时，它都会从“随机化器”工作表中复制和粘贴，并且由于工作表每次都会刷新，因此每次点击按钮时都会随机化。单击加热按钮时会运行以下宏。

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

* EDIT - 添加镜像分配 *

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