指派问题的匈牙利算法

      昨天帮一个同学完成了他的毕业论文上的指派问题的匈牙利算法程序。以前他们跟我讲那算法的时候，他们就没讲清楚。现在回想起来他们说的匈牙利算法都是不完全正确的。因此以前我就在网上随便帮他们找了一个程序，可是发现那程序25行矩阵就会出问题，运行相当长时间，因为那不是用匈牙利算法解决的。

      他们现在被老师逼了，一定要把结果弄出来，没办法了，我也只好认真看了一下匈牙利算法原理。最后选择了Excel的后台VBA 程序来解决。通过一天的努力，这个匈牙利算法已经弄出来了。下面就给出全部的代码。

'=========================================
'作者：大漠.jxzhoumin
'=========================================

Option Base 1
Public r As Integer
Public row_gou() As Integer
Public col_gou() As Integer
Public gou_min_num As Double
'=================================================
Public Function tj(lb) As Integer
     Dim k As Integer
     k = 2
     Do
         Set myR = Sheets(lb).Cells(k, 1)
         If Trim(myR.Value) = "" Then     '出现空记录
            Exit Do
         End If
         k = k + 1
     Loop Until False
     tj = k - 1
End Function
'================================================
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
    Call findmin
Application.ScreenUpdating = True
Worksheets("sheet1").Activate
End Sub
Sub findmin()
Dim num As Double, min_num As Double
r = tj("原始数据")
Call copy_data
With Worksheets("sheet1")
For i = 2 To r
   num = 1000
   For j = 2 To r
       If .Cells(i, j).Value < num Then
            min_num = .Cells(i, j).Value
            num = min_num '获得该行的最小数
       End If
   Next j
   For j = 2 To r
       .Cells(i, j).Value = .Cells(i, j).Value - min_num '将每行减该行最小数
   Next j
Next i
'======================================================================================
For i = 2 To r
   num = 1000
   For j = 2 To r
        If .Cells(j, i).Value < num Then
            min_num = .Cells(j, i).Value
            num = min_num '获得该列的最小数
       End If
   Next j
   For j = 2 To r
       .Cells(j, i).Value = .Cells(j, i).Value - min_num '将每列减该列最小数
   Next j
Next i
End With
Call find_draw_zero
End Sub
Function find_draw_zero()
Dim zero_row As Integer
zero_row = 0
zero_row = findzero()
While zero_row > 0
    Call draw_zero(zero_row)
    zero_row = findzero()
Wend
Call bestvalue
End Function
Function findzero() As Integer
Dim zero_num As Integer, zero_row, zero_col As Integer, min_num As Integer
zero_num = 0 '行，列0元素的个数
min_num = 1000
zero_row = 0
zero_col = 0
With Worksheets("sheet1")
For i = 2 To r
    zero_num = 0
    For j = 2 To r
        If .Cells(i, j).Value = 0 Then
            zero_num = zero_num + 1
        End If
    Next j
    If zero_num <> 0 And zero_num < min_num Then
        min_num = zero_num
        zero_row = i
    End If
Next i
End With
If min_num = 1000 Then
   zero_row = 0
End If
findzero = zero_row
End Function
Sub draw_zero(zero_row As Integer)
Dim zero_col As Integer, i As Integer
zero_col = find_col_num(zero_row)
With Worksheets("sheet1")
    .Cells(zero_row, zero_col).Value = "@" '将对应的0划成@
    For i = 2 To r
         If .Cells(zero_row, i).Value = 0 Then
             .Cells(zero_row, i).Value = "*"  '找到对应的行的0划成*
         End If
    Next i
    For i = 2 To r
         If .Cells(i, zero_col).Value = 0 Then
             .Cells(i, zero_col).Value = "*"  '找到对应的列的0划成*
         End If
    Next i
End With
End Sub
Function find_col_num(zero_row As Integer) As Integer
Dim count As Integer, col_num As Integer, min_count As Integer
min_count = 1000
With Worksheets("sheet1")
     For i = 2 To r
         If .Cells(zero_row, i).Value = 0 Then
             count = 0
             For j = 2 To r
                If .Cells(j, i).Value = 0 Or .Cells(j, i).Value = "*" Then
                    count = count + 1
                End If
             Next j
             If count < min_count Then
                 min_count = count
                 find_col_num = i '找到需要标记的0列的数值，该0的列的0的个数最少
             End If
         End If
     Next i
End With
End Function
Function bestvalue() As Boolean
Dim count As Integer
count = 0
With Worksheets("sheet1")
For i = 2 To r
    For j = 2 To r
         If .Cells(i, j).Value = "@" Then
             count = count + 1
         End If
    Next j
Next i
End With
If count = r - 1 Then
   bestvalue = True
   Call show_infor
   MsgBox "达到最优解！"
Else
   bestvalue = False
   Call draw_gou
   Call find_gou_min_num
   Call row_gou_jian
   Call col_gou_jia
   Call init_second
End If
End Function
Sub draw_gou()
Dim i As Integer, count As Integer
Dim row_num, col_num As Integer
i = 1
Erase row_gou
Erase col_gou
ReDim row_gou(1)
ReDim col_gou(1)
With Worksheets("sheet1")
For i = 2 To r
    count = 0
    For j = 2 To r
        If .Cells(i, j).Value = "@" Then
            count = count + 1
        End If
    Next j
    If count = 0 Then
       row_num = i
       If row_gou(0) = 0 Then
           row_u = 0
       Else
           row_u = UBound(row_gou)
       End If
       If col_gou(0) = 0 Then
           col_u = 0
       Else
           col_u = UBound(col_gou)
       End If
       
       For j = 2 To r
           If .Cells(row_num, j).Value = "*" Then
              col_num = j
           End If
       Next j
           
        If chongfu_row(row_num) Then
             ReDim Preserve row_gou(row_u + 1)
             row_gou(row_u + 1) = row_num  '将行画钩的序列值做标记
         End If
         If chongfu_col(col_num) Then
             ReDim Preserve col_gou(col_u + 1)
             col_gou(col_u + 1) = col_num  '将列画钩的序列值做标记
             Call col_to_row(col_num)
         End If
    End If
Next i
End With
End Sub
Function chongfu_row(ByVal row_num As Integer) As Boolean
row_u = UBound(row_gou)
chongfu_row = True
For i = 1 To row_u
    If row_gou(i) = row_num Then
        chongfu_row = False
    End If
Next i
End Function
Function chongfu_col(ByVal col_num As Integer) As Boolean
col_u = UBound(col_gou)
chongfu_col = True
For i = 1 To col_u
    If col_gou(i) = col_num Then
        chongfu_col = False
    End If
Next i
End Function
Sub col_to_row(ByVal col_num As Integer)
row_u = UBound(row_gou)
col_u = UBound(col_gou)
row_num = 0
With Worksheets("sheet1")
For i = 2 To r
    If .Cells(i, col_num).Value = "@" Then
         row_num = i
         If chongfu_row(row_num) Then
             ReDim Preserve row_gou(row_u + 1)
             row_gou(row_u + 1) = row_num  '将行画钩的序列值做标记
         End If
    For j = 2 To r
        If .Cells(row_num, i).Value = "*" Then
            If chongfu_col(col_num) Then
                 ReDim Preserve col_gou(col_u + 1)
                 col_gou(col_u + 1) = i '将列画钩的序列值做标记
                 'Call col_to_row(i) '全套循环函数得出画钩的行
             End If
         End If
    Next j
    End If
Next i
End With
End Sub
Sub find_gou_min_num()
Dim row_u As Integer, row_num As Integer, min_num As Double
min_num = 1000
row_u = UBound(row_gou)
With Worksheets("sheet1")
For i = 1 To row_u
    For j = 2 To r
         row_num = row_gou(i)
         If .Cells(row_num, j).Value <> "*" And .Cells(row_num, j).Value <> "@" Then
             If .Cells(row_num, j).Value < min_num Then
                 min_num = .Cells(row_num, j).Value
                 gou_min_num = min_num
              End If
         End If
    Next j
Next i
End With
End Sub
Sub row_gou_jian()
Dim row_u As Integer, row_num As Integer
row_u = UBound(row_gou)
With Worksheets("sheet1")
For i = 1 To row_u
    For j = 2 To r
         row_num = row_gou(i)
         If .Cells(row_num, j).Value <> "*" And .Cells(row_num, j).Value <> "@" Then
            .Cells(row_num, j).Value = .Cells(row_num, j) - gou_min_num '将画钩的行的数减去最小数
         End If
    Next j
Next i
End With
End Sub
Sub col_gou_jia()
Dim col_u As Integer, col_num As Integer
col_u = UBound(col_gou)
With Worksheets("sheet1")
For i = 1 To col_u
    col_num = col_gou(i)
    For j = 2 To r
         If .Cells(j, col_num).Value <> "*" And .Cells(j, col_num).Value <> "@" Then
            .Cells(j, col_num).Value = Val(Trim(.Cells(j, col_num).Value)) + gou_min_num '将画钩的行的数减去最小数
         End If
    Next j
Next i
End With
End Sub
Sub init_second()
With Worksheets("sheet1")
     For i = 2 To r
         For j = 2 To r
             If .Cells(i, j).Value = "@" Or .Cells(i, j).Value = "*" Then
                .Cells(i, j).Value = 0
             End If
         Next j
     Next i
End With
Call find_draw_zero
End Sub
Sub show_infor()
With Worksheets("sheet1")
For i = 2 To r
    For j = 2 To r
        If .Cells(i, j).Value = "@" Then
            .Cells(i, j).Value = 1
        Else: .Cells(i, j).Value = 0
        End If
    Next j
Next i
End With
End Sub
Sub copy_data()
For i = 1 To r
    For j = 1 To r
        With Worksheets("原始数据")
            num = .Cells(i, j).Value
        End With
        With Worksheets("sheet1")
            .Cells(i, j).Value = num
        End With
    Next j
Next i
End Sub

 

评论

1 楼 kimcherwoo 2009-01-04  

有java版本吗？