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
4
solved Is there VBA code of the Hungarian Algorithm (Munkres)? [closed]