Option Explicit
Sub MinHamiltonianPath()
Dim mMatrix, m(), z(), ILoop As Integer, Um As Integer
Dim i As Integer, j As Integer, k As Integer
Dim s, sRC, sMax As Double
Dim strPath(), deli, delj
Dim sStr(2), w, u '°üÀ½¹¦Áö·Â ´É±¸¼¼°£°í ALNIOS
ANOGIS
Dim tr, UmILoop
Dim chk As Boolean
Dim L
Dim uvRoute(1 To 1, 1 To 2)
Dim NotFound As Boolean
mMatrix = Selection
Um = UBound(mMatrix, 1)
ReDim m(1 To Um, 1 To Um)
For i = 1 To Um
For j = 1 To Um
m(i, j) = mMatrix(i, j)
Next
Next
Do
UmILoop = Um - ILoop
ReDim z(1 To UmILoop, 1 To UmILoop)
For i = 2 To UmILoop
z(i, 1) = m(i, 1)
Next
For i = 2 To UmILoop
z(1, i) = m(1, i)
Next
For i = 2 To UmILoop
s = ""
For j = 2 To UmILoop
If m(i, j) <> "" Then
If m(i, j) = 0 Then
s = 0: GoTo 1
ElseIf m(i, j) <> 0 Then
If chk = False Then
s = m(i, j): chk = True
Else
If m(i, j) < s Then s = m(i, j): chk = True
End If
End If
End If
Next
chk = False
For j = 2 To UmILoop
If m(i, j) <> "" Then m(i, j) = m(i, j) - Val(s)
Next
sRC = sRC + IIf(s = "", 0, s)
1:
Next
For j = 2 To UmILoop
s = ""
For i = 2 To UmILoop
If m(i, j) <> "" Then
If m(i, j) = 0 Then
s = 0: GoTo 2
ElseIf m(i, j) <> 0 Then
If chk = False Then
s = m(i, j): chk = True
Else
If m(i, j) < s Then s = m(i, j): chk = True
End If
End If
End If
Next
chk = False
For i = 2 To UmILoop
If m(i, j) <> "" Then m(i, j) = m(i, j) - Val(s)
Next
sRC = sRC + IIf(s = "", 0, s)
2:
Next
s = ""
For i = 2 To UmILoop
For j = 2 To UmILoop
If m(i, j) <> "" And m(i, j) = 0 Then
For k = 2 To UmILoop
If k <> i Then
If m(k, j) <> "" Then
If chk = False Then
s = m(k, j): chk = True
Else
If m(k, j) < s Then s = m(k, j): chk =
True
End If
End If
End If
Next
z(i, j) = Val(s)
s = "": chk = False
For k = 2 To UmILoop
If k <> j Then
If m(i, k) <> "" Then
If chk = False Then
s = m(i, k): chk = True
Else
If m(i, k) < s Then s = m(i, k): chk =
True
End If
End If
End If
Next
z(i, j) = z(i, j) + Val(s)
s = ""
End If
If sMax < z(i, j) Then sMax = z(i, j): sStr(1) = m(i, 1): sStr
(2) = m(1, j): deli = i: delj = j
Next
Next
If UmILoop = 3 Then
GoTo 3
End If
For k = deli To UmILoop - 1
For L = 1 To UmILoop
m(k, L) = m(k + 1, L)
Next
Next
For k = delj To UmILoop - 1
For L = 1 To UmILoop
m(L, k) = m(L, k + 1)
Next
Next
For i = 1 To UmILoop
m(i, UmILoop) = ""
m(UmILoop, i) = ""
Next
i = 0
Do
i = i + 1
Loop Until sStr(2) = m(i, 1) Or i = UmILoop + 1
j = 0
Do
j = j + 1
Loop Until sStr(1) = m(1, j) Or j = UmILoop + 1
ILoop = ILoop + 1
ReDim Preserve strPath(1 To 2, 1 To ILoop): strPath(1, ILoop) = sStr
(1): strPath(2, ILoop) = sStr(2)
If i = UmILoop + 1 Or j = UmILoop + 1 Then
If ILoop > 1 And ILoop < Um - 1 Then
For j = 1 To 2
u = strPath(j, ILoop): L = IIf(j = 1, 2, 1)
Do
k = 0
Do
k = k + 1
Loop Until u = strPath(L, k) Or k = ILoop - 1
If u = strPath(L, k) Then
L = IIf(L = 1, 2, 1)
w = strPath(L, k)
u = strPath(L, k)
L = IIf(L = 1, 2, 1)
NotFound = False
Else
NotFound = True
End If
Loop Until NotFound = True Or k = ILoop
uvRoute(1, IIf(j = 1, 2, 1)) = w: w = ""
Next
If uvRoute(1, 1) = "" And uvRoute(1, 2) <> "" Then uvRoute(1, 1) =
strPath(2, ILoop)
If uvRoute(1, 1) <> "" And uvRoute(1, 2) = "" Then uvRoute(1, 2) =
strPath(1, ILoop)
End If
If Not IsEmpty(uvRoute) Then
i = 0: j = 0
Do
i = i + 1
Loop Until uvRoute(1, 1) = m(i, 1) Or i = UmILoop
Do
j = j + 1
Loop Until uvRoute(1, 2) = m(1, j) Or j = UmILoop
m(i, j) = ""
'Debug.Print ILoop; uvRoute(1, 1); uvRoute(1, 2); i; j
End If
uvRoute(1, 1) = ""
uvRoute(1, 2) = ""
Else
m(i, j) = ""
End If
Erase z
s = "": sStr(1) = 0: sStr(2) = 0: sMax = 0
Loop Until ILoop = Um
3:
For i = 2 To 3
For j = 2 To 3
Debug.Print z(i, 1); z(1, j); z(i, j)
If z(i, j) <> "" And z(i, j) = 0 Then
ILoop = ILoop + 1
ReDim Preserve strPath(1 To 2, 1 To ILoop): strPath(1,
ILoop) = z(i, 1): strPath(2, ILoop) = z(1, j)
End If
Next
Next
ReDim strPath1(1 To 1, 1 To Um): Dim O
i = 0: j = 0
Do
i = i + 1
Loop Until strPath(1, i) = 1
strPath1(1, 1) = strPath(1, i): j = 1
Do
j = j + 1: O = strPath(2, i): i = 0
Do
i = i + 1
Loop Until strPath(1, i) = O
strPath1(1, j) = strPath(1, i)
Loop Until j = Um
Selection.Cells(1).Offset(Selection.Rows.Count + 1, 0).Resize(2,
Selection.Rows.Count) = strPath
Selection.Cells(1).Offset(Selection.Rows.Count + 4, 0).Resize(1,
Selection.Rows.Count) = strPath1
Selection.Cells(1).Offset(Selection.Rows.Count + 3, 0) = sRC
End Sub
Function IsLoopHermitian(strPath, sStr) As Boolean
Dim i As Integer, chk1 As Byte, chk2 As Byte
For i = 1 To UBound(strPath, 2) - 1
If strPath(1, i) = sStr(2) Then chk1 = True
If strPath(2, i) = sStr(1) Then chk2 = True
Next
If chk1 = True And chk2 = True Then IsLoopHermitian = True
End Function
