Reputation: 11
Quick Background: I'm a team captain of a relay race whereby runners have put preferences as to what legs they are willing to run. For decades the captains have manually figured out where to put people, I want to automate it. There are Y number of runners (20 or more) for exactly 20 legs.
Current Situation: VERY crude code will find all combinations up to 3 legs of the race but it's clear I need to abstract and probably use arrays to do this. My code skills are rough (self-taught), trying to find assistance to expand below code to n x n instead of currently n x 3.
Sub B2VMacro()
Debug.Print
countRunners
Debug.Print ("Here are the available leg assignments: ")
For i = 2 To countRunners
cellValue = Cells(i, 2).Value
runnerNameLeg1 = Cells(i, 1).Value
If cellValue = "X" Then
For j = 1 To countRunners
cellValue2 = Cells(j, 3).Value
runnerNameLeg2 = Cells(j, 1).Value
If cellValue2 = "X" Then
If runnerNameLeg1 <> runnerNameLeg2 Then
For k = 1 To countRunners
CellValue3 = Cells(k, 4).Value
runnerNameLeg3 = Cells(k, 1).Value
If CellValue3 = "X" Then
If runnerNameLeg1 <> runnerNameLeg2 And runnerNameLeg2 <> runnerNameLeg3 And runnerNameLeg1 <> runnerNameLeg3 Then
Debug.Print (runnerNameLeg1 & " , " & runnerNameLeg2 & " , " & runnerNameLeg3)
End If
End If
Next k
End If
End If
Next j
End If
Next i
End Sub
Function countRunners() As Integer
countRunners = Worksheets("Template").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
End Function
Code works for n x 3 but it's going to become unmanageable expanding this to even 5 x n. Need to figure out how to abstract the code.
Expected Output (comma delineates leg of race):
Runner 1, Runner 2, Runner 4
Runner 1, Runner 3, Runner 4
Runner 2, Runner 3, Runner 4
Runner 3, Runner 1, Runner 4
Runner 3, Runner 2, Runner 4
Only Runner 4 agreed to run leg 3, Runner 2 did not agree to run leg 1, Runner 1 & 3 agreed to run legs 1 and 2 but not 3.
So I'd want every combination to cover all legs given the runner's preferences (X means they are willing to run that leg of the relay race). The full sheet has 20 legs and N runners (currently 20 but some years would be more like 30-40).
Upvotes: 1
Views: 107
Reputation: 34230
Here is a draft of a possible approach. The idea is to work through the legs from first to last, allocating the first available runner to each leg in turn. To get another set of allocations, backtrack from the last leg until a leg is found where an alternate runner can be allocated, then work forward from there as before.
Option Explicit
Option Base 1
Sub Runners()
Dim Allocated() As Boolean
Dim Legs() As Integer
Dim arr() As Variant
Dim col As Integer, row As Integer
Dim tempRow As Integer, colFound As Integer, rept As Integer
Dim lastRow As Integer, lastCol As Integer
Dim nRunners As Integer, nLegs As Integer
Dim outString As String
lastRow = Cells(Rows.Count, "A").End(xlUp).row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
nRunners = lastRow - 1
nLegs = lastCol - 1
ReDim Allocated(nRunners)
ReDim Legs(nLegs)
arr = Range(Cells(2, 2), Cells(lastRow, lastCol))
'Find initial allocation
Call forwardSearch(1, nLegs, 1, nRunners, arr, Allocated, Legs)
Call output(Legs, nLegs)
' Try again
For rept = 1 To 10
Call backTrack(nLegs, 1, nRunners, colFound, arr, Allocated, Legs)
If colFound = 0 Then Exit Sub
'Re-start search
Call forwardSearch(colFound + 1, nLegs, 1, nRunners, arr, Allocated, Legs)
Call output(Legs, nLegs)
Next rept
End Sub
Sub forwardSearch(startCol As Integer, endCol As Integer, startRow As Integer, endRow As Integer, ByRef arr(), ByRef Allocated() As Boolean, ByRef Legs() As Integer)
Dim col As Integer, row As Integer
For col = startCol To endCol
For row = startRow To endRow
If Not Allocated(row) And arr(row, col) = "X" Then
Allocated(row) = True
Legs(col) = row
Exit For
End If
Next row
Next col
End Sub
Sub backTrack(startCol As Integer, endCol As Integer, endRow As Integer, ByRef colFound As Integer, ByRef arr(), ByRef Allocated() As Boolean, ByRef Legs() As Integer)
Dim col As Integer, row As Integer, tempRow As Integer
colFound = 0
For col = startCol To endCol Step -1
tempRow = Legs(col)
For row = Legs(col) + 1 To endRow
If Not Allocated(row) And arr(row, col) = "X" Then
' De-allocate existing runner
Allocated(tempRow) = False
'Allocate new runner
Allocated(row) = True
'Save new runner
Legs(col) = row
colFound = col
Exit Sub
End If
Next row
'Simply de-allocate current runner
Allocated(tempRow) = False
Next col
End Sub
Sub output(Legs() As Integer, nLegs As Integer)
Dim col As Integer
Dim outString As String
outString = "Runner" & Legs(1)
For col = 2 To nLegs
outString = outString & ", Runner" & Legs(col)
Next col
Debug.Print outString
End Sub
Output for test data
Runner1, Runner2, Runner4
Runner1, Runner3, Runner4
Runner3, Runner1, Runner4
Runner3, Runner2, Runner4
To do
In the real data, any particular attempt (or all attempts) at allocating runners to legs may not get all the way to the final leg. Need to adjust program to take this into account. Also use runners' actual names. If the program were ever used on a large scale, change Integer to Long.
Upvotes: 2