【已总结】[第119期]假如你是无人驾驶车上的电脑，你想好了怎么走吗？

袁振涛

1. Public d As Object, d1 As Object, Brr, intCount As Integer, s As New Collection
   
2. Sub lqxs_zd()
   
3.     formatData
   
4.     MsgBox findNextState([a2], [b2], 0)
   
5.     Range("c2").Resize(100, 2).ClearContents
   
6.     [c2].Resize(UBound(Brr), 2) = Brr
   
7. End Sub
   
8. Function findNextState(ByVal strState$, ByVal strEndState$, ByRef intSmallDistance%) As Integer    '参数分别为当前节点与结束节点,最小距离
   
9.     Dim intDistance%, strPath$, i%
   
10.     d1(strState) = 1    '将当前节点标记为已经经过
    
11.     s.Add strState    '入栈
    
12.     If strState = strEndState Then    '如果已经到达目的节点
    
13.         intCount = intCount + 1
    
14.         strPath = getPath
    
15.         intDistance = computeDistance(strPath)
    
16.         Brr(intCount, 1) = intDistance
    
17.         If intSmallDistance = 0 Or intSmallDistance > intDistance Then intSmallDistance = intDistance
    
18.         Brr(intCount, 2) = strPath
    
19.     Else    '如果当前节点不是结束节点,如若仍未标记过则遍历
    
20.         For Each statekey In d(strState).keys
    
21.             If d1(statekey) = 0 Then findNextState = findNextState(statekey, strEndState, intSmallDistance)
    
22.         Next
    
23.     End If
    
24.     d1(strState) = 0    '取消对当前节点的标记
    
25.     s.Remove s.Count    '出栈
    
26.     findNextState = intSmallDistance
    
27. End Function
    
28. Function computeDistance(ByVal strPath$) As Integer    '计算距离
    
29.     Dim Arr, intDistance%, i%
    
30.     Arr = Split(strPath, "-")
    
31.     For i = 0 To UBound(Arr) - 1
    
32.         intDistance = intDistance + d(Arr(i))(Arr(i + 1))
    
33.     Next
    
34.     computeDistance = intDistance
    
35. End Function
    
36. Sub formatData() '初始化字典数据
    
37.     Set d = CreateObject("scripting.dictionary")
    
38.     Set d1 = CreateObject("scripting.dictionary")
    
39.     Dim Arr, i%
    
40.     intCount = 0
    
41.     ReDim Brr(1 To 100, 1 To 2)
    
42.     Arr = Sheets("题目").[a1].CurrentRegion
    
43.     For i = 2 To UBound(Arr)
    
44.         If Not d.exists(Arr(i, 1)) Then Set d(Arr(i, 1)) = CreateObject("scripting.dictionary")
    
45.         If Not d.exists(Arr(i, 2)) Then Set d(Arr(i, 2)) = CreateObject("scripting.dictionary")
    
46.         d(Arr(i, 1))(Arr(i, 2)) = Arr(i, 3)
    
47.         d(Arr(i, 2))(Arr(i, 1)) = Arr(i, 3)
    
48.         d1(Arr(i, 1)) = 0
    
49.         d1(Arr(i, 2)) = 0
    
50.     Next
    
51. End Sub
    
52. Function getPath() As String '根据集合内容计算路径
    
53.     Dim strPath$
    
54.     strPath = s(1)
    
55.     For i = 2 To s.Count
    
56.         strPath = strPath & "-" & s(i)
    
57.     Next
    
58.     getPath = strPath
    
59. End Function
    
60. 
    

复制代码

jsgj2023

请老师看看是否符合要求?

yjh_27

增加了路况功能：0修路不通行；1单向通行；2双向通行
自定义排序函数代码在附件中。

1. Sub lqxs_zd()
   
2. ks = [a2]
   
3. js = [b2]
   
4. 
   
5. R = Sheets("题目").Range("a" & Rows.Count).End(xlUp).Row
   
6. arr = Sheets("题目").Range("a2:d" & R)
   
7. 
   
8. ReDim a2rr(1 To UBound(arr) * 2, 1 To UBound(arr, 2) + 1)
   
9. ReDim jilurr(1 To UBound(a2rr), 1 To 2)
   
10. 
    
11. ii = 0
    
12. For i = 1 To UBound(arr)
    
13.     If arr(i, 4) > 0 Then
    
14.         ii = ii + 1
    
15.         a2rr(ii, 1) = arr(i, 1)
    
16.         a2rr(ii, 2) = arr(i, 2)
    
17.         a2rr(ii, 3) = arr(i, 3)
    
18.     End If
    
19.     If arr(i, 4) > 1 Then
    
20.         ii = ii + 1
    
21.         a2rr(ii, 1) = arr(i, 2)
    
22.         a2rr(ii, 2) = arr(i, 1)
    
23.         a2rr(ii, 3) = arr(i, 3)
    
24.     End If
    
25. Next
    
26. a2rr = YjhSort0(a2rr, "a,1", "1,3")         '按开始点、距离升序
    
27. 
    
28. juli = 0
    
29. lujin = "-" & ks  '路径
    
30. 
    
31. If ks = js Then
    
32.    
    
33. Else
    
34.     Call chazao(ks, js, a2rr, juli, lujin, jilurr, jls)
    
35. End If
    
36. 
    
37. R = Range("c" & Rows.Count).End(xlUp).Row
    
38. Range("c2:d" & R).ClearComments
    
39. If jls > 0 Then
    
40.     Range("c2").Resize(UBound(jilurr), 2) = jilurr
    
41. Else
    
42.     [c2] = ""
    
43.     [d2] = "未找到路径"
    
44. End If
    
45.    
    
46. End Sub
    
47. 
    
48. 
    
49. Sub chazao(ks, js, a2rr, juli, lujin, jilurr, jls)
    
50. 
    
51. For i = 1 To UBound(a2rr)   '可二分法提速
    
52.     If ks = a2rr(i, 1) Then Exit For
    
53. Next
    
54. If i > UBound(a2rr) Then Exit Sub
    
55. 
    
56. If ks = a2rr(i, 2) Then
    
57.     ii = 1   '原路返回了
    
58. Else
    
59.     ii = 0
    
60. End If
    
61. Do
    
62.     If a2rr(i + ii, 1) <> ks Then
    
63.         Exit Do            '该点所有路径走完
    
64.     End If
    
65.    
    
66.     If a2rr(i + ii, 2) = js Then        '找到终点
    
67.         jls = jls + 1
    
68.         If jls = 1 Then
    
69.             jilurr(1, 1) = juli + a2rr(i + ii, 3)
    
70.             jilurr(1, 2) = Mid(lujin, 2) & "-" & js
    
71.         ElseIf jilurr(1, 1) > juli + a2rr(i + ii, 3) Then
    
72.             jilurr(jls, 1) = jilurr(1, 1)
    
73.             jilurr(jls, 2) = jilurr(1, 2)
    
74.             jilurr(1, 1) = juli + a2rr(i + ii, 3)
    
75.             jilurr(1, 2) = Mid(lujin, 2) & "-" & js
    
76.         Else
    
77.             jilurr(jls, 1) = juli + a2rr(i + ii, 3)
    
78.             jilurr(jls, 2) = Mid(lujin, 2) & "-" & js
    
79.         End If
    
80.     Else
    
81.         If Not lujin Like "*-" & a2rr(i + ii, 2) & "-*" Then    '无重复点，找下一点
    
82.             ks1 = a2rr(i + ii, 2)
    
83.             juli1 = juli + a2rr(i + ii, 3)
    
84.             lujin1 = lujin & "-" & ks1
    
85.             Call chazao(ks1, js, a2rr, juli1, lujin1, jilurr, jls)
    
86.         End If
    
87.     End If
    
88.     ii = ii + 1
    
89. Loop Until i + ii > UBound(a2rr)
    
90. 
    
91. End Sub
    

复制代码

小花鹿

1. Sub test()
   
2. Dim ar, i&, j&, d, d1, d2, st, en, cr(1 To 65536, 1 To 2), m&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. ar = Sheet2.[a1].CurrentRegion
   
7. For i = 2 To UBound(ar)
   
8.     d(ar(i, 1)) = d(ar(i, 1)) & "|" & ar(i, 2)
   
9.     d(ar(i, 2)) = d(ar(i, 2)) & "|" & ar(i, 1)
   
10.     d2(ar(i, 1) & "-" & ar(i, 2)) = ar(i, 3)
    
11.     d2(ar(i, 2) & "-" & ar(i, 1)) = ar(i, 3)
    
12. Next i
    
13. st = Sheet1.[a2]
    
14. en = Sheet1.[b2]
    
15. d1(st) = 1
    
16. Call digui(d, d1, st, en, cr, m)
    
17. For i = 1 To m
    
18.     st = Split(cr(i, 2), "-")
    
19.     For j = 0 To UBound(st) - 1
    
20.         cr(i, 1) = cr(i, 1) + d2(st(j) & "-" & st(j + 1))
    
21.     Next j
    
22. Next i
    
23. Sheet1.[c2].Resize(m, 2) = cr
    
24. End Sub
    
25. Sub digui(d, d1, st, en, cr, m)
    
26. Dim tm, i&
    
27. tm = Split(d(st), "|")
    
28. For i = 1 To UBound(tm)
    
29.     If tm(i) = en Then
    
30.         m = m + 1
    
31.         cr(m, 2) = Join(d1.keys, "-") & "-" & en
    
32.     Else
    
33.         d1(tm(i)) = d1(tm(i)) + 1
    
34.         If d1(tm(i)) = 1 Then
    
35.             Call digui(d, d1, tm(i), en, cr, m)
    
36.         End If
    
37.     End If
    
38. Next i
    
39. d1.Remove st
    
40. End Sub

复制代码

paciguard

paciguard 发表于 2017-11-25 02:41

谢谢蓝版主，改好了。。。

1. Dim dic, dicc, St$, Ed$, d, c&, jj, Str$, dd
   
2. Sub lqxs_zd()
   
3. Dim ar, kk&, sta$
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. Set dicc = CreateObject("Scripting.Dictionary")
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set dd = CreateObject("Scripting.Dictionary")
   
8. ar = Sheet2.Range("A2:C" & Sheet2.[a65536].End(3).Row)
   
9. For i = 1 To UBound(ar)
   
10. dic(ar(i, 1) & "-" & ar(i, 2)) = ar(i, 3)
    
11. dic(ar(i, 2) & "-" & ar(i, 1)) = ar(i, 3)
    
12. dicc(ar(i, 1) & "-" & ar(i, 2)) = kk
    
13. dicc(ar(i, 2) & "-" & ar(i, 1)) = kk + 1
    
14. kk = kk + 2
    
15. Next i
    
16. St = Sheet1.Range("A2")
    
17. Ed = Sheet1.Range("B2")
    
18. For jj = 0 To UBound(dic.keys())
    
19. If Split(dic.keys()(jj), "-")(0) = St Then
    
20. sta = St & "-" & Split(dic.keys()(jj), "-")(1)
    
21. Call Findpath(sta, 0)
    
22. End If
    
23. Next jj
    
24. If Sheet1.[c65536].End(3).Row - 1 > 0 Then Sheet1.Range("C2").Resize(Sheet1.[c65536].End(3).Row - 1, 2).ClearContents
    
25. Sheet1.Range("C2").Resize(UBound(d.items()) + 1, 1) = Application.Transpose(d.items())
    
26. Sheet1.Range("D2").Resize(UBound(d.keys()) + 1, 1) = Application.Transpose(d.keys())
    
27. End Sub
    
28. Sub Findpath(ss, ii)
    
29. Dim jjj&, k&
    
30. jjj = ii
    
31. Str = ss
    
32. Do While jjj <= 24
    
33. If (InStr(Str, St) > 0 And InStr(Str, Ed) > 0) Or (jjj >= 24 And InStr(Str, St & "-" & Split(dic.keys()(jj), "-")(1)) > 0 And Str <> St & "-" & Split(dic.keys()(jj), "-")(1)) Then
    
34. If Not d.exists(Str) And (InStr(Str, St) > 0 And InStr(Str, Ed) > 0) Then
    
35. Dim Sumpath
    
36. For k = 0 To UBound(Split(Str, "-")) - 1
    
37. Sumpath = Sumpath + dic(Split(Str, "-")(k) & "-" & Split(Str, "-")(k + 1))
    
38. Next k
    
39. d.Add Str, Sumpath
    
40. End If
    
41. If Not dd.exists(Str) Then
    
42. dd.Add Str, ""
    
43. c = dicc(Split(Str, "-")(UBound(Split(Str, "-")) - 1) & "-" & Split(Str, "-")(UBound(Split(Str, "-"))))
    
44. jjj = c + 1
    
45. Str = Replace(Str, "-" & Split(Str, "-")(UBound(Split(Str, "-"))), "")
    
46. Call Findpath(Str, jjj)
    
47. Else
    
48. Exit Sub
    
49. End If
    
50. Else
    
51. If jjj >= 24 Then Exit Do
    
52. If Split(dic.keys()(jjj), "-")(0) = Split(Str, "-")(UBound(Split(Str, "-"))) And InStr(Str, Split(dic.keys()(jjj), "-")(1)) = 0 Then
    
53. Str = Str & "-" & Split(dic.keys()(jjj), "-")(1)
    
54. If Not dd.exists(Str) Then
    
55. Call Findpath(Str, 0)
    
56. Else
    
57. Exit Do
    
58. End If
    
59. End If
    
60. jjj = jjj + 1
    
61. If jjj >= 25 Then Exit Do
    
62. End If
    
63. Loop
    
64. End Sub
    
65. 
    
66. 
    
67. 
    
68. 
    
69. 
    
70. 
    
71. 
    

复制代码

paciguard

请参照附件。。。。。。。。。。

zopey

1. Sub gd_serach()
   
2. Range("c2:d9999").ClearContents
   
3. 
   
4. Dim i%, k%, dic As Object, xm(1 To 255)
   
5. Set dic = CreateObject("Scripting.Dictionary")
   
6. 
   
7. With Sheets("题目")
   
8. For i = 2 To .[a2].End(4).Row
   
9.     If Not dic.Exists(.Cells(i, 1).Value) Then
   
10.        k = k + 1
    
11.        dic(.Cells(i, 1).Value) = k
    
12.        xm(k) = .Cells(i, 1).Value
    
13.     End If
    
14.    
    
15.     If Not dic.Exists(.Cells(i, 2).Value) Then
    
16.        k = k + 1
    
17.        dic(.Cells(i, 2).Value) = k
    
18.        xm(k) = .Cells(i, 2).Value
    
19.     End If
    
20. Next
    
21. End With
    
22. 
    
23. 'arr邻接矩阵
    
24. Dim j%, arr() As Integer
    
25. ReDim arr(1 To k, 1 To k)
    
26. 
    
27. For i = 1 To k
    
28. For j = 1 To k
    
29.    If i = j Then
    
30.       arr(i, j) = 0
    
31.    Else
    
32.       arr(i, j) = -1
    
33.    End If
    
34. Next
    
35. Next
    
36. 
    
37. With Sheets("题目")
    
38. For i = 2 To .[a2].End(4).Row
    
39.     arr(dic(.Cells(i, 1).Value), dic(.Cells(i, 2).Value)) = .Cells(i, 3).Value
    
40.     arr(dic(.Cells(i, 2).Value), dic(.Cells(i, 1).Value)) = .Cells(i, 3).Value
    
41. Next
    
42. End With
    
43. 
    
44. 
    
45. 'brr 权值数组，crr 标号上色
    
46. Dim cStack As New Collection, ks%, temp%, crr() As Boolean
    
47. ReDim crr(1 To k)
    
48. 
    
49. 
    
50. ks = dic([a2].Value)
    
51. crr(ks) = True
    
52. cStack.Add ks
    
53. 
    
54. haha:
    
55. For i = temp + 1 To k
    
56.     If arr(ks, i) > 0 And crr(i) = False Then
    
57.        crr(i) = True: cStack.Add i
    
58.        If i = dic([b2].Value) Then
    
59.          Cells(n + 2, 4).Value = xm(cStack.Item(1))
    
60.          For j = 2 To cStack.Count
    
61.              Cells(n + 2, 4).Value = Cells(n + 2, 4).Value & "-" & xm(cStack.Item(j))
    
62.              Cells(n + 2, 3).Value = Cells(n + 2, 3).Value + arr(cStack.Item(j - 1), cStack.Item(j))
    
63.          Next
    
64.          n = n + 1
    
65.          Exit For
    
66.        End If
    
67.        ks = i: temp = 0: GoTo haha
    
68.     End If
    
69. Next
    
70. 
    
71. temp = cStack.Item(cStack.Count): crr(temp) = False: cStack.Remove cStack.Count
    
72. 
    
73. 
    
74. If cStack.Count = 0 Then
    
75.     Exit Sub
    
76. Else
    
77.    ks = cStack.Item(cStack.Count): GoTo haha
    
78. End If
    
79. 
    
80. Set cStack = Nothing
    
81. 
    
82. End Sub

复制代码

Moneky

1. 'by Moneky
   
2. Dim dic_Path As Dictionary, dic_Path2 As Dictionary '有效path，当前搜索path
   
3. Dim dic As Dictionary
   
4. Dim minPath As String, minLength As Long
   
5. Sub lqxs_zd()
   
6.     Dim sht As Worksheet, r As Long, ACrr
   
7.     Set sht = Worksheets("题目")
   
8.     ACrr = sht.Range("a2:c" & sht.Range("a1").End(xlDown).Row)
   
9.     Set dic = New Dictionary
   
10.     For r = LBound(ACrr) To UBound(ACrr)
    
11.         If Not dic.Exists(ACrr(r, 1)) Then dic.Add ACrr(r, 1), New Dictionary
    
12.         If Not dic.Exists(ACrr(r, 2)) Then dic.Add ACrr(r, 2), New Dictionary
    
13.         dic(ACrr(r, 1)).Add ACrr(r, 2), ACrr(r, 3)
    
14.         dic(ACrr(r, 2)).Add ACrr(r, 1), ACrr(r, 3)
    
15.     Next
    
16.     Set dic_Path2 = New Dictionary
    
17.     Set dic_Path = New Dictionary
    
18.     minPath = ""
    
19.     minLength = 2147483647 '初始化为最大long值
    
20.     Goo True, "", Range("a2").Text, Range("b2").Text
    
21.     Range("c2:d65535").Clear
    
22.     Range("c2").Resize(dic_Path.Count, 1) = WorksheetFunction.Transpose(dic_Path.Items)
    
23.     Range("d2").Resize(dic_Path.Count, 1) = WorksheetFunction.Transpose(dic_Path.Keys)
    
24.     MsgBox minPath & vbNewLine & _
    
25.            "length=" & CStr(minLength), vbInformation + vbOKOnly, "Eersoft"
    
26. End Sub
    
27. Sub Goo(blFirst As Boolean, u As String, p As String, t As String)
    
28.         '是否为第一个点   上一个点     当前点        目标点
    
29.     Dim s As String, i As Long, ii As Long, pl As Long, sp As String
    
30.     If blFirst Then
    
31.         dic_Path2.Add p, 0
    
32.         For i = 0 To dic(p).Count - 1
    
33.             s = dic(p).Keys()(i)
    
34.             If Not dic_Path2.Exists(s) And s <> t Then '没有搜索过且不是终点
    
35.                 Goo False, p, s, t
    
36.             End If
    
37.             If s = t Then '到达目标，输出路径与距离
    
38.                 sp = Join(dic_Path2.Keys(), "-") & "-" & t
    
39.                 pl = dic_Path2.Items()(dic_Path2.Count - 1) + dic(p)(t)
    
40.                 dic_Path(sp) = pl
    
41.                 If pl < minLength Then '记录最短路径信息
    
42.                     minPath = sp
    
43.                     minLength = pl
    
44.                 End If
    
45.             End If
    
46.         Next
    
47.     Else
    
48.         dic_Path2.Add p, dic_Path2.Items()(dic_Path2.Count - 1) + dic(u)(p) '累加长度
    
49.         For i = 0 To dic(p).Count - 1
    
50.             s = dic(p).Keys()(i)
    
51.             If Not dic_Path2.Exists(s) And s <> t Then
    
52.                 Goo False, p, s, t
    
53.             End If
    
54.             If s = t Then '到达目标，输出路径与距离
    
55.                 sp = Join(dic_Path2.Keys(), "-") & "-" & t
    
56.                 pl = dic_Path2.Items()(dic_Path2.Count - 1) + dic(p)(t)
    
57.                 dic_Path(sp) = pl
    
58.                 If pl < minLength Then '记录最短路径信息
    
59.                     minPath = sp
    
60.                     minLength = pl
    
61.                 End If
    
62.             End If
    
63.         Next
    
64.         dic_Path2.Remove (p) '移除该点
    
65.     End If
    
66. End Sub
    

复制代码

香川群子

字典+数组循环 【广度遍历搜素】

写了详细注释，但是没有定义变量，哈哈哈。因为这个是初学者能够搞定的简单算法。
代码贴一下：

1. Sub test() 'by kagawa 2017/12/1
   
2.    
   
3.     ar = Sheet2.[a1].CurrentRegion '读取A1区域数据
   
4.     m = UBound(ar) '最大行数
   
5.    
   
6.     Set dic = CreateObject("Scripting.Dictionary") '建立字典
   
7.     For i = 2 To m '遍历原始数据
   
8.         t1 = ar(i, 1): t2 = ar(i, 2)
   
9.         dic(t1) = dic(t1) & " " & t2 '记录路径关系
   
10.         dic(t2) = dic(t2) & " " & t1 '记录路径关系
    
11.         dic(t1 & "-" & t2) = ar(i, 3) '记录路径关系对应距离
    
12.         dic(t2 & "-" & t1) = ar(i, 3) '记录路径关系对应距离
    
13.     Next
    
14.    
    
15.     t1 = [a2] '"E" '输入起点位置
    
16.     t3 = [b2] '"B" '输入终点位置
    
17.    
    
18.     ReDim sr(m * m, 2), jg(m, 1) '定义存放过程、结果的数组sr(),jg()
    
19.     sr(0, 0) = t1: sr(0, 2) = "-" & t1 & "-"
    
20.     Do
    
21.         For i = k1 To k2 '遍历检查过程数组sr
    
22.             r = sr(i, 1) '提取累计路程r
    
23.             s = sr(i, 2) '提取路径s
    
24.             t1 = sr(i, 0) '提取路径节点t1
    
25.             
    
26.             tr = Split(dic(t1)) '根据字典提取节点t1的关联节点集合tr
    
27.             n = UBound(tr) '关联节点总数n
    
28.             For j = 1 To n '遍历关联节点
    
29.                 t2 = tr(j) '提取关联节点t2
    
30.                 If InStr(s, "-" & t2 & "-") = 0 Then '如果路径中不含这个节点
    
31.                     If t2 = t3 Then '如果已到终点t3
    
32.                         jg(k3, 0) = r + dic(t1 & "-" & t2) '输出累计路程
    
33.                         jg(k3, 1) = Mid(s & t2, 2) '输出路径
    
34.                         k3 = k3 + 1 '有效路径数k3
    
35.                     Else '未到终点时记录新的过程路径
    
36.                         k = k + 1 '过程数k+1
    
37.                         sr(k, 0) = t2 '记录新的节点
    
38.                         sr(k, 1) = r + dic(t1 & "-" & t2) '记录累计路程
    
39.                         sr(k, 2) = s & t2 & "-" '记录路径
    
40.                     End If
    
41.                 End If
    
42.             Next
    
43.         Next
    
44.         If k = k2 Then Exit Do '如果不再有新的路径增加则退出循环
    
45.         k1 = k2 + 1 '更新下一轮过程检查的起始行
    
46.         k2 = k '更新下一轮过程检查的结束行位置
    
47.     Loop
    
48.    
    
49.     [a1].CurrentRegion.Offset(1, 2) = ""
    
50.     [c2].Resize(k3, 2) = jg '输出有效路径以及累计路程
    
51.     [c2].Resize(k3, 2).Sort [c2], 1 '按A列路程升序排序
    
52.    
    
53.     MsgBox "找到 " & k3 & " 条有效路径," & vbCr & "最短路程 = " & [c2]
    
54. End Sub

复制代码

Nick_Chen0622

是要使用Djs算法么