Java指派问题_指派问题的匈牙利算法

'=========================================

'作者：大漠.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 = 2To r

num = 1000

For j = 2To r

If .Cells(i, j).Value

min_num = .Cells(i, j).Value

num = min_num '获得该行的最小数

End If

Next j

For j = 2To r

.Cells(i, j).Value = .Cells(i, j).Value - min_num '将每行减该行最小数

Next j

Next i

'======================================================================================

For i = 2To r

num = 1000

For j = 2To r

If .Cells(j, i).Value

min_num = .Cells(j, i).Value

num = min_num '获得该列的最小数

End If

Next j

For j = 2To 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 = 2To r

zero_num = 0

For j = 2To r

If .Cells(i, j).Value = 0Then

zero_num = zero_num + 1

End If

Next j

If zero_num <> 0And zero_num

min_num = zero_num

zero_row = i

End If

Next i

End With

If min_num = 1000Then

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 = 2To r

If .Cells(zero_row, i).Value = 0Then

.Cells(zero_row, i).Value = "*"'找到对应的行的0划成*

End If

Next i

For i = 2To r

If .Cells(i, zero_col).Value = 0Then

.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 = 2To r

If .Cells(zero_row, i).Value = 0Then

count = 0

For j = 2To r

If .Cells(j, i).Value = 0Or .Cells(j, i).Value ="*"Then

count = count + 1

End If

Next j

If count

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 = 2To r

For j = 2To r

If .Cells(i, j).Value = "@"Then

count = count + 1

End If

Next j

Next i

End With

If count = r - 1Then

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 = 2To r

count = 0

For j = 2To r

If .Cells(i, j).Value = "@"Then

count = count + 1

End If

Next j

If count = 0Then

row_num = i

If row_gou(0) =0Then

row_u = 0

Else

row_u = UBound(row_gou)

End If

If col_gou(0) =0Then

col_u = 0

Else

col_u = UBound(col_gou)

End If

For j = 2To 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 = 1To 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 = 1To 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 = 2To 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 = 2To 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 = 1To row_u

For j = 2To 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 = .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 = 1To row_u

For j = 2To 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 = 1To col_u

col_num = col_gou(i)

For j = 2To 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 = 2To r

For j = 2To 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 = 2To r

For j = 2To 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 = 1To r

For j = 1To 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