JRubenol
JRubenol

Reputation: 11

How do I abstract my VBA code to handle n x n matrix smoothly?

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.

enter image description here

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

Answers (1)

Tom Sharpe
Tom Sharpe

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

Related Questions