Is there VBA code of the Hungarian Algorithm (Munkres)?

Question

I need help translating the Hungarian Algorithm to VBA, specifally how you handle "covering" a matrix row or column. I found some basic code on Bytes.com but it doesn't work for every matrix, and often results in a "Too Many Loops" error. The algorithm is supposed to have O(n3) runtime, so it shouldn't run "too many loops" with a 6x6 matrix. Any help is appreciated.

Answer 1

Here you go:

Option Base 1
Sub HungarianAlgorithm()
'   Code rewritten and expanded by excelCoder321 for the purpose of:
'   1) demonstrating intermediary steps, as a companion to the detailed explanation of Munkres Algorithm at https://brc2.com/the-algorithm-workshop/
'   2) allowing N>M-matrices (more rows than columns)
'   3) adding option to maximize costs, not just minimize them.

        '>>>  Set the following values:  <<<
        
                    nrow = 3           'Set the number of rows in your Cost Matrix (it CAN be greater than number of columns).
                    ncol = 3            'Set the number of columns in your Cost Matrix (it CAN be greater than number of rows).
                    Maximize = False    'If True, this will maximize the total cost instead of minimizing it.
                    See_Work = True     'If True, it will output the intermediary steps, not only the results.
                                                                                Dim C() As Double ' Do not change
                                                                                ReDim C(nrow, ncol) ' Do not change
        '>>>  Now set your cost values here, and run the program!  <<<
        
                    C(1, 1) = 1         'column 1, row 1
                    C(2, 1) = 2         'column 1, row 2
                    C(3, 1) = 3

                    C(1, 2) = 2         'column 2, row 1
                    C(2, 2) = 4         'etc.
                    C(3, 2) = 6

                    C(1, 3) = 3
                    C(2, 3) = 6
                    C(3, 3) = 9


'   =================================================================================================================
    Dim CopyC()     As Double       'Copy of Cost Matrix, needed to save original matrix if Maximize = True.
    Dim Transposed() As Variant     'If more rows than columns, transpose matrix for algorithm to yield good results.
    Dim M()         As Integer      'Masked Matrix to store "Stars" (stores as 1's) and "Primes" (stored as 2's).
    Dim Temp()      As Integer      'Temporary Matrix to store Primes and Stars for step 5.
    Dim R_cov()     As Integer      'Array to store "covered" rows.
    Dim C_cov()     As Integer      'Array to store "covered" columns.
    Dim saved_row   As Integer      'Variable to store row number that has Primed zero from Step 4 to be used in Step 5.
    Dim saved_col   As Integer      'Variable to store column number that has Primed zero from Step 4 and Step 5.
    Dim star_in_row As Boolean      'To store if there is a star in row in Step 4.
    Dim i           As Integer      'Rows increment.
    Dim j           As Integer      'Columns increment.
    Dim k           As Integer      'Columns increment (in Step 4 only).
    Dim Max         As Double       'Variable to store the largest element in the original matrix. Used in Step4 and for Maximizing.
    Dim Sum         As Double       'Variable to sum up all the selected element values.
    Dim output      As String       'string for outputs to immediate window.
    Dim ntemp       As Integer      'If more rows than columns, need this to swap nrow with ncol.
    Dim Transpose   As Boolean
    
    'prints original matrix
    If See_Work Then
        For i = 1 To nrow
            output = output & " | "
            For j = 1 To ncol
                output = output & C(i, j) & " | "
            Next
            output = output & vbCrLf
        Next
        Debug.Print "Original Matrix"
        Debug.Print output
    End If
    
    'If there are more rows than columns, this program needs to transpose the matrix
    If nrow > ncol Then
        Transpose = True
        Transposed = WorksheetFunction.Transpose(C)
        ReDim C(ncol, nrow)
        For i = 1 To nrow
            For j = 1 To ncol
                C(j, i) = Transposed(j, i)
            Next
        Next
        ntemp = nrow
        nrow = ncol
        ncol = ntemp

    End If      'Since Booleans begin as False, no need to write Else Tranpose = False
    
    'After determining whether or not to transpose, it can dimension these arrays properly
    ReDim M(nrow, ncol)
    ReDim Temp(nrow, ncol)
    ReDim X(nrow, ncol)
    ReDim C_cov(ncol)
    ReDim R_cov(nrow)
    
    If See_Work And Transpose Then
        Debug.Print "Since there are more Rows than Columns, this program needs to transpose the matrix first."
        Call Print_to_Immediate("Transpose", C, M, R_cov, C_cov)
    End If
    
    CopyC = C
    Max = WorksheetFunction.Max(C) 'also used in Step4
    If Maximize Then
        For i = 1 To nrow
            For j = 1 To ncol
                C(i, j) = Max - C(i, j)
            Next
        Next
        If See_Work Then
            Debug.Print "When maximizing, each element is transformed by subtracting its value from the greatest " & vbCrLf & _
            "matrix value. For example, the first element becomes: " & Max & " - " & CopyC(1, 1) & " = " & Max - CopyC(1, 1)
            Call Print_to_Immediate("Subtract each value by largest value to begin Maximizing", C, M, R_cov, C_cov)
        End If
    End If
    
Step_1: 'For each row of the matrix, find the smallest element and subtract it from every element in its row.
    For i = 1 To nrow
        Min = C(i, 1)
        For j = 1 To ncol
            If Min > C(i, j) Then
                Min = C(i, j)
            End If
        Next
        For j = 1 To ncol
            C(i, j) = C(i, j) - Min
        Next
    Next
    If See_Work Then
        Call Print_to_Immediate("1. Subtract smallest value in each row from each element in that row.", C, M, R_cov, C_cov)
    End If
    
Step_2: 'Find a zero (Z) in the resulting matrix. If there is no starred zero in its row or column, star Z.
        'Repeat for each element in the matrix.
    For i = 1 To nrow
        For j = 1 To ncol
            If C(i, j) = 0 And R_cov(i) = 0 And C_cov(j) = 0 Then
                M(i, j) = 1 'star it
                R_cov(i) = 1
                C_cov(j) = 1
            End If
        Next
    Next
    For i = 1 To nrow
        R_cov(i) = 0
    Next
    For j = 1 To ncol
        C_cov(j) = 0
    Next
    If See_Work Then
        Call Print_to_Immediate("2. Star a zero with no starred zeroes in its row or column. Repeat if other zeroes qualify.", C, M, R_cov, C_cov)
    End If
    GoTo Step_3
    
Step_3: 'Cover each column containing a starred zero. If k columns are covered, where k=min(n,m), the starred zeros describe a
        'complete set of unique assignments. In this case, Go to Step 7 (aka DONE), otherwise, Go to Step 4.
    colCount = 0
    For i = 1 To nrow
        For j = 1 To ncol
            If M(i, j) = 1 Then     'if starred
                C_cov(j) = 1
                colCount = colCount + 1
                Exit For
            End If
        Next
    Next
    
    If colCount >= ncol Or colCount >= nrow Then
        If See_Work Then
            Call Print_to_Immediate("3. Let k=min(n,m). Since k columns can be covered, we are done.", C, M, R_cov, C_cov)
        End If
        GoTo Step_7
    End If
    If See_Work Then
        Call Print_to_Immediate("3. Cover each column containing a starred zero.", C, M, R_cov, C_cov)
    End If
    GoTo Step_4
    
Step_4: 'Find a noncovered zero and prime it. If there is no starred zero in the row containing this primed zero,
        'Go to Step 5. Otherwise, cover this row and uncover the column containing the starred zero. Continue in
        'this manner until there are no uncovered zeros left. Save the smallest uncovered value and Go to Step 6.
Repeat_Step_4a:
    For i = 1 To nrow
        For j = 1 To ncol
            If C(i, j) = 0 And R_cov(i) = 0 And C_cov(j) = 0 Then
                M(i, j) = 2 'prime it
                star_in_row = False 'initiate as false before for loop
                For k = 1 To ncol
                    If M(i, k) = 1 Then 'if there is a starred zero in same row as the newly primed zero
                        star_in_row = True
                        Exit For
                    End If
                Next
                If star_in_row = False Then
                    saved_row = i
                    saved_col = j
                    If See_Work Then
                        Call Print_to_Immediate("4. Prime an uncovered 0. If 0* in same row, cover row, uncover column of 0*. Repeat for uncovered 0's. If no 0* in same row, Step5.", C, M, R_cov, C_cov)
                    End If
                    GoTo Step_5
                Else
                    R_cov(i) = 1
                    C_cov(k) = 0 'uncover column or row with star
                    GoTo Repeat_Step_4a
                End If
            End If
        Next
    Next
    minval = Max
    For i = 1 To nrow
        For j = 1 To ncol
            If R_cov(i) = 0 And C_cov(j) = 0 And minval > C(i, j) Then
                minval = C(i, j)
            End If
        Next
    Next
    If See_Work Then
        Call Print_to_Immediate("4. Prime an uncovered 0. If 0* in same row, cover row, uncover column of 0*. Repeat for uncovered 0's. Save the minimum uncovered value (" & minval & ") for Step 6.", C, M, R_cov, C_cov)
    End If
    GoTo Step_6
    
Step_5: 'Construct a series of alternating primed and starred zeros as follows. Let Z0 represent the uncovered
        'primed zero found in Step 4. Let Z1 denote the starred zero in the column of Z0 (if any). Let Z2 denote
        'the primed zero in the row of Z1 (there will always be one). Continue until the series terminates at a
        'primed zero that has no starred zero in its column. Unstar each starred zero of the series, star each
        'primed zero of the series, erase all primes and uncover every line in the matrix. Return to Step 3.
    ReDim Temp(nrow, ncol) As Integer 'reset to zeroes
    Temp(saved_row, saved_col) = 2
Repeat_Step_5a:
    For i = 1 To nrow
        If M(i, saved_col) = 1 Then     'if starred zero in same column (there may not be one)
            Temp(i, saved_col) = 1      'star it
            For j = 1 To ncol
                If M(i, j) = 2 Then     'if prime in same row as starred zero (there will always be one)
                    Temp(i, j) = 2      'prime it
                    saved_col = j
                    GoTo Repeat_Step_5a
                End If
            Next
        End If
    Next
    For i = 1 To nrow
        For j = 1 To ncol
            If Temp(i, j) = 1 Then      'if star
                M(i, j) = 0             'unstar this
            ElseIf Temp(i, j) = 2 Then  'if prime
                M(i, j) = 1             'star this
            End If
            If M(i, j) = 2 Then         'erase any primes
                M(i, j) = 0
            End If
        Next
    Next
    For i = 1 To nrow
        R_cov(i) = 0
    Next
    For j = 1 To ncol
        C_cov(j) = 0
    Next
    If See_Work Then
        Call Print_to_Immediate("5. From last 0' from Step4, look for 0* in same column, find O' in 0*'s row. Keep alternating until no 0* in same col. Unstar those 0*'s. Star 0primes.", C, M, R_cov, C_cov)
    End If
    GoTo Step_3
    
Step_6: 'Add the value found in Step 4 to every element of each covered row, and subtract it from every element
        'of each uncovered column. (Some elements might be added to and also subtracted from, cancelling out any change)
        'Return to Step 4 without altering any stars, primes, or covered lines.
    For i = 1 To nrow
        For j = 1 To ncol
            If R_cov(i) = 1 Then
                C(i, j) = C(i, j) + minval
            End If
            If C_cov(j) = 0 Then
                C(i, j) = C(i, j) - minval
            End If
        Next
    Next
    If See_Work Then
        Call Print_to_Immediate("6. Subtract the value (" & minval & ") from uncovered elements, but add it to elements with both a covered row and covered column.", C, M, R_cov, C_cov)
    End If
    GoTo Step_4
    
Step_7:
    output = ""
    If Transpose = True Then
        For j = 1 To ncol
            output = output & " | "
            For i = 1 To nrow
                output = output & CopyC(i, j)
                If M(i, j) = 1 Then
                    output = output & "* |  "
                    Sum = Sum + CopyC(i, j)
                Else
                    output = output & "  |  "
                End If
            Next
            output = output & vbCrLf
        Next
    Else
        For i = 1 To nrow
            output = output & "|  "
            For j = 1 To ncol
                output = output & CopyC(i, j)
                If M(i, j) = 1 Then
                    output = output & "* |  "
                    Sum = Sum + CopyC(i, j)
                Else
                    output = output & "  |  "
                End If
            '' for matrix with only 1's and 0's, substitute this code inside the for loop
'                output = output & M(i, j) & " | "
'                If M(i, j) = 1 Then
'                    Sum = Sum + CopyC(i, j)
'                End If
            Next
            output = output & vbCrLf
        Next
    End If
    Debug.Print "Results:" & vbCrLf & output & _
    "Stars (*) denote one way to optimally assign the rows. (There may be more than one way.)" & vbCrLf & _
    "Sum of chosen elements = " & Sum & "."
End Sub
Sub Print_to_Immediate(step As String, C() As Double, M() As Integer, R_cov() As Integer, C_cov() As Integer)
    Debug.Print "Step: " & step
    output = ""
    For i = 1 To UBound(C, 1)
        output = output & "|"
        For j = 1 To UBound(C, 2)
            If R_cov(i) = 1 Then
                output = output & "--"
            Else
                output = output & "  "
            End If
            If C_cov(j) = 1 Then
                output = output & ":"
            Else
                output = output & " "
            End If
            output = output & C(i, j)
            If M(i, j) = 2 Then
                output = output & "'"
            ElseIf M(i, j) = 1 Then
                output = output & "*"
            Else
                output = output & " "
            End If
            If C_cov(j) = 1 Then
                output = output & ":"
            Else
                output = output & " "
            End If
            If R_cov(i) = 1 Then
                output = output & "--"
            Else
                output = output & "  "
            End If
            output = output & "|"
        Next
        output = output & vbCrLf
    Next
    Debug.Print output
End Sub