|
Sub test2()
Dim ar, br&(), cr, dr, dic, i&, j&, k&, m&, n&, r&, s&, t&, tms#
tms = Timer
ar = Sheets(1).[a1].CurrentRegion '读取节点之间的路程数据表
m = UBound(ar): n = UBound(ar, 2) '最大行m、最大列n
ReDim br&(1 To m, 1 To n) '数组b记录累计路程
br(1, 1) = ar(1, 1) '起始位置
Set dic = CreateObject("Scripting.Dictionary") '字典记录当前路程值 对应的节点位置
dic(ar(1, 1)) = " " & 1 & " " & 1 '起始位置
Do
kr = dic.keys '提取当前所有路程值
s = kr(0)
For k = 1 To UBound(kr)
If kr(k) < s Then s = kr(k) '检查当前最小路程值
Next
cr = Split(dic(s)) '还原最短路程对应的节点位置
For k = 1 To UBound(cr) Step 2 '依次检查
i = cr(k): j = cr(k + 1) '还原行、列位置
If i > 1 Then t = ar(i - 1, j) + br(i, j): If br(i - 1, j) = 0 Then br(i - 1, j) = t: dic(t) = dic(t) & " " & i - 1 & " " & j
If i < m Then t = ar(i + 1, j) + br(i, j): If br(i + 1, j) = 0 Then br(i + 1, j) = t: dic(t) = dic(t) & " " & i + 1 & " " & j
If j > 1 Then t = ar(i, j - 1) + br(i, j): If br(i, j - 1) = 0 Then br(i, j - 1) = t: dic(t) = dic(t) & " " & i & " " & j - 1
If j < n Then t = ar(i, j + 1) + br(i, j): If br(i, j + 1) = 0 Then br(i, j + 1) = t: dic(t) = dic(t) & " " & i & " " & j + 1
'依次检查上、下、左、右 是否为空或有更小路程
Next
dic.Remove s '字典中去掉这个当前最小路程值
Loop Until br(m, n) '检查直到终点
Debug.Print Format(Timer - tms, "0.000s"); br(m, n)
Sheet2.Activate
[a1].CurrentRegion.Interior.ColorIndex = 0
[a1].CurrentRegion = ""
[a1].Resize(m, n) = br
ReDim cr(1 To m, 1 To n)
i = m: j = n
cr(i, j) = br(i, j)
Cells(i, j).Interior.ColorIndex = 7
s = ar(i, j)
Do
ReDim dr(3)
If i > 1 Then dr(0) = br(i - 1, j): t = dr(0): r = 0
If i < m Then dr(1) = br(i + 1, j): t = dr(1): r = 1
If j > 1 Then dr(2) = br(i, j - 1): t = dr(2): r = 2
If j < n Then dr(3) = br(i, j + 1): t = dr(3): r = 3
For k = 0 To 3
If dr(k) Then If dr(k) < t Then t = dr(k): r = k
Next
If r = 0 Then
i = i - 1
ElseIf r = 1 Then
i = i + 1
ElseIf r = 2 Then
j = j - 1
ElseIf r = 3 Then
j = j + 1
End If
cr(i, j) = ar(i, j)
Cells(i, j).Interior.ColorIndex = 7
s = s + ar(i, j)
Loop Until i + j = 2
Debug.Print s
Sheet3.Activate
[a1].Resize(m + 1, n + 1) = ""
[a1].Resize(m, n) = cr
MsgBox Format(Timer - tms, "0.000s") & vbCr & s
End Sub |
|