- 浏览: 149052 次
- 性别:
- 来自: 武汉
文章分类
最新评论
-
zhangyou1010:
您好,请问http://www.learn.edu.cn/ 这 ...
Blackboard在线教学管理平台 -
yh1350:
有没有兼容 Firefox的呀
固定表格第一行(表头固定),其他行可以上下滚动 -
javaLife:
楼主,这句classid="clsid:1663ed ...
页面打印方法 -
lgch123:
cms做的。。。没什么意义
最近我的新作品,大家支持一下了! -
east_java:
这么多站 运营如何啊
最近我的新作品,大家支持一下了!
昨天帮一个同学完成了他的毕业论文上的指派问题的匈牙利算法程序。以前他们跟我讲那算法的时候,他们就没讲清楚。现在回想起来他们说的匈牙利算法都是不完全正确的。因此以前我就在网上随便帮他们找了一个程序,可是发现那程序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
- N个货格N货物任务指派问题.rar (44.2 KB)
- 描述: Excel文档,完整的匈牙利算法程序
- 下载次数: 23
发表评论
-
最近我的新作品,大家支持一下了!
2009-10-25 00:27 980最近搞了不少的网站,可是都没有去推广,大家支持一下哦: 网址 ... -
三次指数平滑法的预测
2008-06-03 10:30 4477昨天晚上帮同学完成三次指数平滑法的预测模型算法实现,这个就很简 ... -
变权多因素模糊评判模型算法程序
2008-06-02 19:45 1157今天弄了个变权多因素模糊评判模型算法程序。也是帮 ... -
兰州市旅游计划中... ...
2008-05-26 11:03 806兰州市旅游计划 第一站:脚踏滨河路 白天走北滨河西路(下午,大 ... -
基于条形码的高校教材管理系统的设计与应用
2008-05-24 10:07 1556摘要:为了改善目前高校教材管理的混乱和复杂局面,提高教材管理工 ... -
快速启动栏消失
2008-05-23 17:54 2661今天,我的office出现了点问题,我把Application ... -
联想网络硬盘——lenovodata
2008-05-23 14:03 16012008-05-22 13:33 ... -
哀 悼
2008-05-23 14:02 6092008-05-20 11:24 昨天 ... -
系统说明书完成
2008-05-23 14:01 6692008-05-18 18:26 这 ... -
地震,晚上又来惊扰我们
2008-05-23 14:00 5482008-05-18 11:08 昨天晚上, ... -
今天完成了800块钱的网站
2008-05-23 13:58 7152008-05-16 23:16 从这 ... -
今天学会修改gif格式的图片了
2008-05-23 13:57 13092008-05-10 21:07 为了帮一个 ... -
今天开始学习ActionScript
2008-05-23 13:57 768这个视频播放器的进展碰到了点问题,所以我现在有必要去了解一下f ... -
五一看车展
2008-05-23 13:56 6222008-05-02 10:52 昨天上 ... -
老师很生气!
2008-05-23 13:55 6312008-04-24 23:21 今天晚上 ... -
大春天的,兰州竟然下了一场大雪!
2008-05-23 13:55 6172008-04-21 11:12 兰州昨天晚 ... -
Web模仿了一个CS的界面,大家看看
2008-05-23 13:54 7222008-04-14 22:24 这两 ... -
今天晚上又去见导师了
2008-05-23 13:53 7352008-04-10 22:54 今天 ... -
刚完成了一个网站
2008-05-23 13:51 607这2008-03-31 20:08 两天帮我大哥完成了 ... -
小小的一个忙
2008-05-23 13:50 5702008-03-29 20:36 今天 ...
相关推荐
匈牙利算法指派问题matlab代码
matlab匈牙利算法求解指派问题
若能在系数矩阵(bij)中找出n个独立的0元素;则令解矩阵(xij)中对应这n个独立的0元素取值为1,其它元素取值为0。将其代入目标函数中得到zk=0,...这就是以(bij)为系数矩阵的指派问题的最优解。也就得到了问题的最优解。
基于匈牙利算法的指派问题优化分析PPT课件.pptx
程序实现了匈牙利算法应用于指派问题,输入指派成本矩阵C,给出最小成本及使得成本最小的最优指派
给出了指派问题的匈牙利算法的编程实现,通过调试。
匈牙利算法在企业员工指派问题的应用
MATLAB源码集锦-基于匈牙利算法的指派问题优化分析
指派问题的匈牙利算法,基本算法实现。 Hungarian algorithm for assignment problem
基于匈牙利算法的指派问题优化分析.zip
hungary_代码_matlab_匈牙利算法_指派问题_源码
Hungary Solution 匈牙利算法的MATLAB程序(用以解决分配(指派)问题)
在生活中经常遇到这样的问题,某单位需完成n项任务,恰好有n个人可承担这些任务。由于每人的专长不同,各人完成任务不同(或所费时间),效率也不同。...这问题称为指派问题或分派问题(Assignment problem)。
目前为止,求解指派问题的最快的算法,比匈牙利算法快n倍
此程序,用vc++源代码实现了指派问题的匈牙利算法,
matlab程序匈牙利算法指派问题
基于匈牙利算法的Z配送中心人员指派