Chinaunix首页 | 论坛 | 博客
  • 博客访问: 1676185
  • 博文数量: 585
  • 博客积分: 14610
  • 博客等级: 上将
  • 技术积分: 7402
  • 用 户 组: 普通用户
  • 注册时间: 2008-05-15 10:52
文章存档

2013年(5)

2012年(214)

2011年(56)

2010年(66)

2009年(44)

2008年(200)

分类: C/C++

2008-08-15 09:05:29

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

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

Java代码 复制代码
  1. '=========================================  
  2. '作者:大漠.jxzhoumin  
  3. '=========================================  
  4.   
  5. Option Base 1  
  6. Public r As Integer  
  7. Public row_gou() As Integer  
  8. Public col_gou() As Integer  
  9. Public gou_min_num As Double  
  10. '=================================================  
  11. Public Function tj(lb) As Integer  
  12.      Dim k As Integer  
  13.      k = 2  
  14.      Do  
  15.          Set myR = Sheets(lb).Cells(k, 1)  
  16.          If Trim(myR.Value) = "" Then     '出现空记录  
  17.             Exit Do  
  18.          End If  
  19.          k = k + 1  
  20.      Loop Until False  
  21.      tj = k - 1  
  22. End Function  
  23. '================================================  
  24. Private Sub CommandButton1_Click()  
  25. Application.ScreenUpdating = False  
  26.     Call findmin  
  27. Application.ScreenUpdating = True  
  28. Worksheets("sheet1").Activate  
  29. End Sub  
  30. Sub findmin()  
  31. Dim num As Double, min_num As Double  
  32. r = tj("原始数据")  
  33. Call copy_data  
  34. With Worksheets("sheet1")  
  35. For i = 2 To r  
  36.    num = 1000  
  37.    For j = 2 To r  
  38.        If .Cells(i, j).Value < num Then  
  39.             min_num = .Cells(i, j).Value  
  40.             num = min_num '获得该行的最小数  
  41.        End If  
  42.    Next j  
  43.    For j = 2 To r  
  44.        .Cells(i, j).Value = .Cells(i, j).Value - min_num '将每行减该行最小数  
  45.    Next j  
  46. Next i  
  47. '======================================================================================  
  48. For i = 2 To r  
  49.    num = 1000  
  50.    For j = 2 To r  
  51.         If .Cells(j, i).Value < num Then  
  52.             min_num = .Cells(j, i).Value  
  53.             num = min_num '获得该列的最小数  
  54.        End If  
  55.    Next j  
  56.    For j = 2 To r  
  57.        .Cells(j, i).Value = .Cells(j, i).Value - min_num '将每列减该列最小数  
  58.    Next j  
  59. Next i  
  60. End With  
  61. Call find_draw_zero  
  62. End Sub  
  63. Function find_draw_zero()  
  64. Dim zero_row As Integer  
  65. zero_row = 0  
  66. zero_row = findzero()  
  67. While zero_row > 0  
  68.     Call draw_zero(zero_row)  
  69.     zero_row = findzero()  
  70. Wend  
  71. Call bestvalue  
  72. End Function  
  73. Function findzero() As Integer  
  74. Dim zero_num As Integer, zero_row, zero_col As Integer, min_num As Integer  
  75. zero_num = 0 '行,列0元素的个数  
  76. min_num = 1000  
  77. zero_row = 0  
  78. zero_col = 0  
  79. With Worksheets("sheet1")  
  80. For i = 2 To r  
  81.     zero_num = 0  
  82.     For j = 2 To r  
  83.         If .Cells(i, j).Value = 0 Then  
  84.             zero_num = zero_num + 1  
  85.         End If  
  86.     Next j  
  87.     If zero_num <> 0 And zero_num < min_num Then  
  88.         min_num = zero_num  
  89.         zero_row = i  
  90.     End If  
  91. Next i  
  92. End With  
  93. If min_num = 1000 Then  
  94.    zero_row = 0  
  95. End If  
  96. findzero = zero_row  
  97. End Function  
  98. Sub draw_zero(zero_row As Integer)  
  99. Dim zero_col As Integer, i As Integer  
  100. zero_col = find_col_num(zero_row)  
  101. With Worksheets("sheet1")  
  102.     .Cells(zero_row, zero_col).Value = "@" '将对应的0划成@  
  103.     For i = 2 To r  
  104.          If .Cells(zero_row, i).Value = 0 Then  
  105.              .Cells(zero_row, i).Value = "*"  '找到对应的行的0划成*  
  106.          End If  
  107.     Next i  
  108.     For i = 2 To r  
  109.          If .Cells(i, zero_col).Value = 0 Then  
  110.              .Cells(i, zero_col).Value = "*"  '找到对应的列的0划成*  
  111.          End If  
  112.     Next i  
  113. End With  
  114. End Sub  
  115. Function find_col_num(zero_row As Integer) As Integer  
  116. Dim count As Integer, col_num As Integer, min_count As Integer  
  117. min_count = 1000  
  118. With Worksheets("sheet1")  
  119.      For i = 2 To r  
  120.          If .Cells(zero_row, i).Value = 0 Then  
  121.              count = 0  
  122.              For j = 2 To r  
  123.                 If .Cells(j, i).Value = 0 Or .Cells(j, i).Value = "*" Then  
  124.                     count = count + 1  
  125.                 End If  
  126.              Next j  
  127.              If count < min_count Then  
  128.                  min_count = count  
  129.                  find_col_num = i '找到需要标记的0列的数值,该0的列的0的个数最少  
  130.              End If  
  131.          End If  
  132.      Next i  
  133. End With  
  134. End Function  
  135. Function bestvalue() As Boolean  
  136. Dim count As Integer  
  137. count = 0  
  138. With Worksheets("sheet1")  
  139. For i = 2 To r  
  140.     For j = 2 To r  
  141.          If .Cells(i, j).Value = "@" Then  
  142.              count = count + 1  
  143.          End If  
  144.     Next j  
  145. Next i  
  146. End With  
  147. If count = r - 1 Then  
  148.    bestvalue = True  
  149.    Call show_infor  
  150.    MsgBox "达到最优解!"  
  151. Else  
  152.    bestvalue = False  
  153.    Call draw_gou  
  154.    Call find_gou_min_num  
  155.    Call row_gou_jian  
  156.    Call col_gou_jia  
  157.    Call init_second  
  158. End If  
  159. End Function  
  160. Sub draw_gou()  
  161. Dim i As Integer, count As Integer  
  162. Dim row_num, col_num As Integer  
  163. i = 1  
  164. Erase row_gou  
  165. Erase col_gou  
  166. ReDim row_gou(1)  
  167. ReDim col_gou(1)  
  168. With Worksheets("sheet1")  
  169. For i = 2 To r  
  170.     count = 0  
  171.     For j = 2 To r  
  172.         If .Cells(i, j).Value = "@" Then  
  173.             count = count + 1  
  174.         End If  
  175.     Next j  
  176.     If count = 0 Then  
  177.        row_num = i  
  178.        If row_gou(0) = 0 Then  
  179.            row_u = 0  
  180.        Else  
  181.            row_u = UBound(row_gou)  
  182.        End If  
  183.        If col_gou(0) = 0 Then  
  184.            col_u = 0  
  185.        Else  
  186.            col_u = UBound(col_gou)  
  187.        End If  
  188.          
  189.        For j = 2 To r  
  190.            If .Cells(row_num, j).Value = "*" Then  
  191.               col_num = j  
  192.            End If  
  193.        Next j  
  194.              
  195.         If chongfu_row(row_num) Then  
  196.              ReDim Preserve row_gou(row_u + 1)  
  197.              row_gou(row_u + 1) = row_num  '将行画钩的序列值做标记  
  198.          End If  
  199.          If chongfu_col(col_num) Then  
  200.              ReDim Preserve col_gou(col_u + 1)  
  201.              col_gou(col_u + 1) = col_num  '将列画钩的序列值做标记  
  202.              Call col_to_row(col_num)  
  203.          End If  
  204.     End If  
  205. Next i  
  206. End With  
  207. End Sub  
  208. Function chongfu_row(ByVal row_num As Integer) As Boolean  
  209. row_u = UBound(row_gou)  
  210. chongfu_row = True  
  211. For i = 1 To row_u  
  212.     If row_gou(i) = row_num Then  
  213.         chongfu_row = False  
  214.     End If  
  215. Next i  
  216. End Function  
  217. Function chongfu_col(ByVal col_num As Integer) As Boolean  
  218. col_u = UBound(col_gou)  
  219. chongfu_col = True  
  220. For i = 1 To col_u  
  221.     If col_gou(i) = col_num Then  
  222.         chongfu_col = False  
  223.     End If  
  224. Next i  
  225. End Function  
  226. Sub col_to_row(ByVal col_num As Integer)  
  227. row_u = UBound(row_gou)  
  228. col_u = UBound(col_gou)  
  229. row_num = 0  
  230. With Worksheets("sheet1")  
  231. For i = 2 To r  
  232.     If .Cells(i, col_num).Value = "@" Then  
  233.          row_num = i  
  234.          If chongfu_row(row_num) Then  
  235.              ReDim Preserve row_gou(row_u + 1)  
  236.              row_gou(row_u + 1) = row_num  '将行画钩的序列值做标记  
  237.          End If  
  238.     For j = 2 To r  
  239.         If .Cells(row_num, i).Value = "*" Then  
  240.             If chongfu_col(col_num) Then  
  241.                  ReDim Preserve col_gou(col_u + 1)  
  242.                  col_gou(col_u + 1) = i '将列画钩的序列值做标记  
  243.                  'Call col_to_row(i) '全套循环函数得出画钩的行  
  244.              End If  
  245.          End If  
  246.     Next j  
  247.     End If  
  248. Next i  
  249. End With  
  250. End Sub  
  251. Sub find_gou_min_num()  
  252. Dim row_u As Integer, row_num As Integer, min_num As Double  
  253. min_num = 1000  
  254. row_u = UBound(row_gou)  
  255. With Worksheets("sheet1")  
  256. For i = 1 To row_u  
  257.     For j = 2 To r  
  258.          row_num = row_gou(i)  
  259.          If .Cells(row_num, j).Value <> "*" And .Cells(row_num, j).Value <> "@" Then  
  260.              If .Cells(row_num, j).Value < min_num Then  
  261.                  min_num = .Cells(row_num, j).Value  
  262.                  gou_min_num = min_num  
  263.               End If  
  264.          End If  
  265.     Next j  
  266. Next i  
  267. End With  
  268. End Sub  
  269. Sub row_gou_jian()  
  270. Dim row_u As Integer, row_num As Integer  
  271. row_u = UBound(row_gou)  
  272. With Worksheets("sheet1")  
  273. For i = 1 To row_u  
  274.     For j = 2 To r  
  275.          row_num = row_gou(i)  
  276.          If .Cells(row_num, j).Value <> "*" And .Cells(row_num, j).Value <> "@" Then  
  277.             .Cells(row_num, j).Value = .Cells(row_num, j) - gou_min_num '将画钩的行的数减去最小数  
  278.          End If  
  279.     Next j  
  280. Next i  
  281. End With  
  282. End Sub  
  283. Sub col_gou_jia()  
  284. Dim col_u As Integer, col_num As Integer  
  285. col_u = UBound(col_gou)  
  286. With Worksheets("sheet1")  
  287. For i = 1 To col_u  
  288.     col_num = col_gou(i)  
  289.     For j = 2 To r  
  290.          If .Cells(j, col_num).Value <> "*" And .Cells(j, col_num).Value <> "@" Then  
  291.             .Cells(j, col_num).Value = Val(Trim(.Cells(j, col_num).Value)) + gou_min_num '将画钩的行的数减去最小数  
  292.          End If  
  293.     Next j  
  294. Next i  
  295. End With  
  296. End Sub  
  297. Sub init_second()  
  298. With Worksheets("sheet1")  
  299.      For i = 2 To r  
  300.          For j = 2 To r  
  301.              If .Cells(i, j).Value = "@" Or .Cells(i, j).Value = "*" Then  
  302.                 .Cells(i, j).Value = 0  
  303.              End If  
  304.          Next j  
  305.      Next i  
  306. End With  
  307. Call find_draw_zero  
  308. End Sub  
  309. Sub show_infor()  
  310. With Worksheets("sheet1")  
  311. For i = 2 To r  
  312.     For j = 2 To r  
  313.         If .Cells(i, j).Value = "@" Then  
  314.             .Cells(i, j).Value = 1  
  315.         Else: .Cells(i, j).Value = 0  
  316.         End If  
  317.     Next j  
  318. Next i  
  319. End With  
  320. End Sub  
  321. Sub copy_data()  
  322. For i = 1 To r  
  323.     For j = 1 To r  
  324.         With Worksheets("原始数据")  
  325.             num = .Cells(i, j).Value  
  326.         End With  
  327.         With Worksheets("sheet1")  
  328.             .Cells(i, j).Value = num  
  329.         End With  
  330.     Next j  
  331. Next i  
  332. End Sub 
阅读(2686) | 评论(1) | 转发(0) |
给主人留下些什么吧!~~

chinaunix网友2010-02-21 10:48:12

这个算法可能还有问题,在某些极其特殊情况下会死循环,不过一般不会。Kuhn提出的匈牙利算法只是他自己这样叫而已。后来的匈牙利算法就是增广路调整,国内教科书上给出的算法都是Kuhn的,所以都是错的,这个效率很差,不如直接增广路调整