excel - Generate Even Amount of Runs in Left and Right Lanes for Racers

Question

I'm working on a spreadsheet for a soap box derby type race that can automatically generate an even amount of runs in the left and right line per racer. It also will randomize who races against who. Currently, I have 6 heats and a button above each one. It pulls from a list of racers with a randomly generated number in the cell next to it using the method shown here: https://www.extendoffice.com/documents/excel/4591-excel-random-selection-no-duplicates.html

This is what the sheet looks like.
[![img][1]][1] The 'DON'T TOUCH' column is then copied to another sheet and placed in each heat when a button is pressed above that heat. The heat sheet looks like this: ![img][2]

Each time a heat button is clicked, it will copy and paste from the "Randomizer" sheet and since the sheet refreshes each time, it will be randomized on each button click. The following macro runs when a heat button is clicked.

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

I need to improve the randomizer so that each racer has an even amount of runs in the left and right lane (3 times each side). I'm not sure how to go about doing this and couldn't find any examples online of a similar situation (drag race heats, golf outings, etc). I thought of recording right and left lane each time a heat button is clicked, but not sure how to implement that into the existing randomizer. Or all the heats need to be generated at once and right and left lanes can represent a 0 and 1 in the randomizer equation.

Any suggestion on how to accomplish this? Thanks!

Edit: Removed images to protect names

标签： excelrandomvba

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