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

尽情飞舞

一个点允许经过两次吗？比如e-f-a-tk1-tk3-a-b，a点经过了两次，这算是从e到b的一条路径吗？
还是每个点只能经过一次？

唐伯狼

1. Private arr       '数据源
   
2. Private brr(1 To 100000, 1 To 2)   '中间数组 以起点出发的所有路径,不论终点
   
3. Private x As Long    '中间数据的计数变量
   
4. Private 起点$, 终点$ '设置起点和终点
   
5. Sub 主程序()
   
6.     Dim mrr '所有符合条件路径的目标数组
   
7.     Dim i&, k&, crr
   
8.     arr = Sheets("题目").Range("a1").CurrentRegion
   
9.     起点 = Sheets(1).Range("a2")
   
10.     终点 = Sheets(1).Range("b2")
    
11.     Call test(起点, 0)
    
12.     ReDim mrr(1 To x, 1 To 2)   '筛选终点为B的所有路径 写入mrr
    
13.     For i = 1 To x
    
14.         crr = Split(brr(i, 1), "-")
    
15.         If crr(UBound(crr)) = 终点 Then
    
16.             k = k + 1
    
17.             mrr(k, 1) = brr(i, 2)
    
18.             mrr(k, 2) = brr(i, 1)
    
19.         End If
    
20.     Next
    
21.     Sheets(1).Range("c2:d" & Rows.Count).ClearContents
    
22.     Sheets(1).Range("c2").Resize(k, 2) = mrr    '输出结果
    
23.     End   '重置private变量
    
24. End Sub
    
25. Sub test(ByVal str As String, ByVal num As Long)   '递归程序   第一参数是路径, 第二参数储存距离
    
26.     Dim crr, st$, i&
    
27.     crr = Split(str, "-")
    
28.     st = crr(UBound(crr))
    
29.     For i = 2 To UBound(arr)
    
30.         If arr(i, 1) = st And InStr(str, arr(i, 2)) = 0 Then   '自动驾驶不兜圈 不折返
    
31.             x = x + 1
    
32.             brr(x, 1) = str & "-" & arr(i, 2)
    
33.             brr(x, 2) = num + arr(i, 3)
    
34.             If arr(i, 2) <> 终点 Then                    '如果没有到达目的地 继续递归
    
35.                 Call test(brr(x, 1), brr(x, 2))
    
36.             End If
    
37.         ElseIf arr(i, 2) = st And InStr(str, arr(i, 1)) = 0 Then
    
38.             x = x + 1
    
39.             brr(x, 1) = str & "-" & arr(i, 1)
    
40.             brr(x, 2) = num + arr(i, 3)
    
41.             If arr(i, 1) <> 终点 Then
    
42.                 Call test(brr(x, 1), brr(x, 2))
    
43.             End If
    
44.         End If
    
45.     Next
    
46. End Sub

复制代码

老师辛苦

尽情飞舞

1. Option Explicit
   
2. Private dic As New Dictionary, ResultCounter As Long, Result(1 To 1000, 1 To 2), ShortcutMileage As Long, Shortcut As String
   
3. 
   
4. Sub driverless()
   
5.     ShortcutMileage = 10000
   
6.    
   
7.     Dim arr, i As Long, j As Long
   
8.     With Worksheets("题目")
   
9.         arr = .[a1].CurrentRegion
   
10.         For i = 2 To UBound(arr)'用字典嵌套求出每个站点可以通往哪些不同的站点
    
11.             For j = 1 To 2
    
12.                 If Not dic.Exists(arr(i, j)) Then
    
13.                     Set dic(arr(i, j)) = New Dictionary
    
14.                 End If
    
15.             Next
    
16.             dic(arr(i, 1))(arr(i, 2)) = arr(i, 3)'字典value储存相应路径的距离
    
17.             dic(arr(i, 2))(arr(i, 1)) = arr(i, 3)
    
18.         Next
    
19.         Erase arr
    
20.         
    
21.         Call digui(0, dic("E").Keys, "E", "E", 0)
    
22. 
    
23.     End With
    
24.         
    
25.     With Worksheets("Sheet1")
    
26.         .[c2].Resize(1000, 2).Clear
    
27.         .[c2].Resize(ResultCounter, 2) = Result
    
28.     End With
    
29.    
    
30.     MsgBox "最短路径为" & Shortcut & "，长" & ShortcutMileage & "公里"
    
31.    
    
32.     Set dic = Nothing
    
33.     ResultCounter = 0
    
34.     Erase Result
    
35.     ShortcutMileage = 0
    
36.    
    
37. End Sub
    
38. 
    
39. 
    
40. Sub digui(x, stops, str, starts, mileages)
    
41. 'x遍历站点，stops为当前站点所连接的所有站点，str为当前路径，starts为当前出发站，mileages为当前路径总长
    
42.     If InStr(str, stops(x)) = 0 Then'如果路径str尚未经过站点stops(x)，则判断该站点是否B，如果是写入结果数组，否则写入当前路径
    
43.         If stops(x) = "B" Then
    
44.             ResultCounter = ResultCounter + 1
    
45.             Result(ResultCounter, 2) = str & "-" & stops(x)
    
46.             Result(ResultCounter, 1) = mileages + dic(starts)(stops(x))
    
47.             If Result(ResultCounter, 1) < ShortcutMileage Then'判断该路径是否最短路径
    
48.                 ShortcutMileage = Result(ResultCounter, 1)
    
49.                 Shortcut = Result(ResultCounter, 2)
    
50.             End If
    
51.         Else
    
52.             Call digui(0, dic(stops(x)).Keys, str & "-" & stops(x), stops(x), mileages + dic(starts)(stops(x)))
    
53.         End If
    
54.     End If
    
55.     If x < UBound(stops) Then'如果当前站点为B或者为终点，则连接下一可能站点
    
56.         Call digui(x + 1, stops, str, starts, mileages)
    
57.     End If
    
58. End Sub

复制代码

怪兽不乖丨Si

1. <div class="blockcode"><blockquote>Option Explicit
   
2. Dim i, p, a
   
3. Dim LineMine
   
4. Dim PathMine
   
5. Dim PathNum As Long
   
6. Dim StationStart
   
7. Dim StationEnd
   
8. Dim PathNew As Integer
   
9. Dim LineNumber As Integer
   
10. 
    
11. Sub main()
    
12. Dim now As Integer
    
13. StationStart = ThisWorkbook.Sheets("sheet1").Cells(2, 1)            '定义起点
    
14. StationEnd = ThisWorkbook.Sheets("sheet1").Cells(2, 2)              '定义终点
    
15. With ThisWorkbook.Sheets("题目")                                    '读取道路数据
    
16.     LineNumber = .Cells(Rows.Count, 1).End(xlUp).Row - 1
    
17.     LineMine = Range(.Cells(2, 1), .Cells(LineNumber * 2 + 1, 3))   '正向
    
18.     For i = 1 To LineNumber                                         '反向
    
19.         LineMine(LineNumber + i, 1) = .Cells(i + 1, 2)
    
20.         LineMine(LineNumber + i, 2) = .Cells(i + 1, 1)
    
21.         LineMine(LineNumber + i, 3) = .Cells(i + 1, 3)
    
22.     Next
    
23. End With
    
24. PathNum = WorksheetFunction.Fact(LineNumber - 2) / WorksheetFunction.Fact(0)
    
25. ReDim PathMine(1 To PathNum, 1 To 2) As Variant                     '记录路径，第一维为编号，第二维1记录路径，2记录长度
    
26. PathNew = 1                                                         '新路径编号
    
27. now = PathNew                                                       '为了迭代，设立个中间变量
    
28. Call PathAdd(now)                                                   '迭代过程，筛选，在路径中添加节点
    
29. a = 2                                                               '输出结果部分
    
30. With ThisWorkbook.Sheets("sheet1")
    
31.     For p = 1 To PathNew
    
32.         If Right(PathMine(p, 1), Len(PathMine(p, 1)) - InStrRev(PathMine(p, 1), "-")) = StationEnd Then
    
33.             .Cells(a, 3) = PathMine(p, 2)
    
34.             .Cells(a, 4) = PathMine(p, 1)
    
35.             a = a + 1
    
36.         End If
    
37.     Next
    
38. End With
    
39. Call SortMain                                                       '排序
    
40. End Sub
    
41. 
    
42. Sub PathAdd(n)   '
    
43. Dim StationNow As String
    
44. Dim pi As Integer
    
45. Dim now As Integer
    
46. Dim FirstOrNot As Boolean
    
47. Dim Pathnow(1 To 2) As Variant
    
48. FirstOrNot = True                                                   '新增路径判断变量
    
49. If PathMine(n, 1) = "" Then                                         '找到目前路径最后一个节点
    
50.     PathMine(n, 1) = StationStart
    
51.     StationNow = StationStart
    
52. Else
    
53.     StationNow = Right(PathMine(n, 1), Len(PathMine(n, 1)) - InStrRev(PathMine(n, 1), "-"))
    
54. End If
    
55. If StationNow = StationEnd Then                                     '判断最终路径是否为终点
    
56.     Exit Sub
    
57. Else
    
58.     Pathnow(1) = PathMine(n, 1)
    
59.     Pathnow(2) = PathMine(n, 2)
    
60.     For pi = 1 To LineNumber * 2
    
61.         If LineMine(pi, 1) = StationNow Then                        '循环检索以最终节点为起点的道路
    
62.             If InStr(Pathnow(1), LineMine(pi, 2)) = 0 Then          '判断道路是否重复
    
63.                 If FirstOrNot = True Then                           '判断是否需要新增路径
    
64.                     now = n
    
65.                     PathMine(now, 1) = Pathnow(1) & "-" & LineMine(pi, 2)   '在路径中新增节点
    
66.                     PathMine(now, 2) = Pathnow(2) + LineMine(pi, 3)         '增加路径长度
    
67.                     Call PathAdd(now)                               '迭代过程，继续检索下一个节点
    
68.                     FirstOrNot = False
    
69.                 Else
    
70.                     PathNew = PathNew + 1
    
71.                     now = PathNew
    
72.                     PathMine(now, 1) = Pathnow(1) & "-" & LineMine(pi, 2)
    
73.                     PathMine(now, 2) = Pathnow(2) + LineMine(pi, 3)
    
74.                     Call PathAdd(now)
    
75.                 End If
    
76.             End If
    
77.         End If
    
78.     Next
    
79. End If
    
80. End Sub
    
81. 
    
82. Sub SortMain()
    
83. Dim rng As Range
    
84. With ThisWorkbook.Worksheets("Sheet1")
    
85.     Set rng = Range(.Cells(2, 3), .Cells((.Cells(.Rows.Count, 3).End(xlUp).Row), 4))
    
86. End With
    
87.     rng.Select
    
88.     ThisWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    
89.     ThisWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1"), _
    
90.         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
91.     With ThisWorkbook.Worksheets("Sheet1").Sort
    
92.         .SetRange rng
    
93.         .Header = xlNo
    
94.         .MatchCase = False
    
95.         .Orientation = xlTopToBottom
    
96.         .SortMethod = xlPinYin
    
97.         .Apply
    
98.     End With
    
99. 
    
100. End Sub
     

复制代码

liulang0808

1. Public d
   
2. Public a
   
3. Public arr
   
4. Sub lqxs_zd()
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheets(2).[a1].CurrentRegion
   
7.     [c2:d2].Value = ""
   
8.     d("E") = 0
   
9.     a = 6
   
10.     dg ("E")
    
11.     Set Rng = Rows(2).Find(WorksheetFunction.Min(Rows(2)), lookat:=xlWhole)
    
12.     [c2] = Rng.Value
    
13.     [d2] = Cells(1, Rng.Column)
    
14. End Sub
    
15. Sub dg(str1 As String)
    
16. 
    
17.     For j = 2 To UBound(arr)
    
18.         If (arr(j, 1) = "B" And arr(j, 2) = str1) Or (arr(j, 2) = "B" And arr(j, 1) = str1) Then
    
19.             d("B") = arr(j, 3)
    
20. 
    
21.             Cells(1, a) = Join(d.keys, "-")
    
22.             Cells(2, a) = WorksheetFunction.Sum(d.items)
    
23.             a = a + 1
    
24. 
    
25.             d.Remove "B"
    
26.         Else
    
27.             If arr(j, 1) = str1 And Not d.exists(arr(j, 2)) Then
    
28.                 d(arr(j, 2)) = arr(j, 3)
    
29.                 dg (arr(j, 2))
    
30. 
    
31.             Else
    
32.                 If arr(j, 2) = str1 And Not d.exists(arr(j, 1)) Then
    
33.                     d(arr(j, 1)) = arr(j, 3)
    
34.                     dg (arr(j, 1))
    
35. 
    
36.                 End If
    
37.             End If
    
38.             
    
39.             
    
40.         End If
    
41.     Next j
    
42.     d.Remove str1
    
43. End Sub

复制代码

说不好

初学者参与一下试试

1. Option Explicit
   
2. Option Base 1
   
3. Public pp As Integer, d As Object
   
4. Sub aa()
   
5. Dim i As Integer, s As String, br(), j As Integer, ar, k As Integer
   
6. pp = 0
   
7. Range("c2:d10000").ClearContents
   
8. ar = Sheets("题目").Range("a2:c" & Sheets("题目").[a65536].End(3).Row)
   
9. Set d = CreateObject("Scripting.Dictionary")
   
10. For i = 1 To UBound(ar)
    
11.     s = "": j = 0
    
12.     If ar(i, 1) = Cells(2, 1) Then
    
13.        s = ar(i, 1) & "-" & ar(i, 2)
    
14.        If Not d.Exists(s) Then
    
15.           pp = pp + 1
    
16.           d(s) = pp
    
17.           ReDim Preserve br(3, pp)
    
18.           br(1, pp) = ar(i, 3)
    
19.           br(2, pp) = s
    
20.           If ar(i, 2) <> Cells(2, 2) Then br(3, pp) = ar(i, 2) Else br(3, pp) = "止"
    
21.           j = 1
    
22.        End If
    
23.     End If
    
24.     If ar(i, 2) = Cells(2, 1) Then
    
25.        s = ar(i, 2) & "-" & ar(i, 1)
    
26.        If Not d.Exists(s) Then
    
27.           pp = pp + 1
    
28.           d(s) = pp
    
29.           ReDim Preserve br(3, pp)
    
30.           br(1, pp) = ar(i, 3)
    
31.           br(2, pp) = s
    
32.           If ar(i, 1) <> Cells(2, 2) Then br(3, pp) = ar(i, 1) Else br(3, pp) = "止"
    
33.           j = 1
    
34.        End If
    
35.     End If
    
36.     If j = 1 Then
    
37.        BB br, ar
    
38.     End If
    
39. Next
    
40. If pp > 0 Then
    
41.    ReDim cr(1 To pp, 1 To 2)
    
42.    k = 0
    
43.    For i = 1 To pp
    
44.       If br(3, i) = "止" Then
    
45.          k = k + 1
    
46.          cr(k, 1) = br(1, i)
    
47.          cr(k, 2) = br(2, i)
    
48.       End If
    
49.    Next
    
50.    If k > 0 Then [c2].Resize(k, 2) = cr
    
51. End If
    
52. Set d = Nothing
    
53. End Sub
    
54. Sub BB(br(), ar)
    
55. Dim i As Integer, j As Integer, k As Integer, s As String
    
56. For i = 1 To UBound(br, 2)
    
57.    For j = 1 To UBound(ar)
    
58.        If (InStr(br(2, i), ar(j, 1)) = 0 Or InStr(br(2, i), ar(j, 2)) = 0) And (ar(j, 1) = br(3, i) Or ar(j, 2) = br(3, i)) Then
    
59.           s = br(2, i) & "-" & IIf(ar(j, 1) = br(3, i), ar(j, 2), ar(j, 1))
    
60.           k = br(1, i)
    
61.           If Not d.Exists(s) Then
    
62.              pp = pp + 1
    
63.              d(s) = pp
    
64.              ReDim Preserve br(3, pp)
    
65.              br(1, pp) = ar(j, 3) + k
    
66.              br(2, pp) = s
    
67.              If ar(j, 1) = br(3, i) Then
    
68.                 If ar(j, 2) <> Cells(2, 2) Then br(3, pp) = ar(j, 2) Else br(3, pp) = "止"
    
69.              End If
    
70.              If ar(j, 2) = br(3, i) Then
    
71.                 If ar(j, 1) <> Cells(2, 2) Then br(3, pp) = ar(j, 1) Else br(3, pp) = "止"
    
72.              End If
    
73.              BB br, ar
    
74.           End If
    
75.         End If
    
76.     Next
    
77. Next
    
78. End Sub
    

复制代码

yangyangzhifeng

最后一天看到，试试看

1. Sub TEST()
   
2.     Dim arr, matrix&(1 To 9, 1 To 9), route&(1 To 9), flag&(1 To 9), i&, j&, r&, k&, st$, dis&
   
3.     arr = Sheet1.Range("e23:n32"): r = 1
   
4.     For i = 2 To UBound(arr)
   
5.         For j = i + 1 To UBound(arr, 2)
   
6.             matrix(i - 1, j - 1) = arr(i, j)
   
7.             matrix(j - 1, i - 1) = arr(i, j)
   
8.         Next
   
9.     Next
   
10.     route(1) = 1: flag(1) = 1: j = 2
    
11.     Do While j > 1
    
12.         For i = route(j) + 1 To UBound(flag)
    
13.             If flag(i) = 0 Then
    
14.                 If matrix(i, route(j - 1)) > 0 Or matrix(route(j - 1), i) > 0 Then Exit For
    
15.             End If
    
16.         Next
    
17. 
    
18.         If i <= UBound(flag) Then
    
19.             If i = UBound(flag) Then
    
20.                 If route(j) > 0 Then flag(route(j)) = 0
    
21.                 route(j) = i
    
22.                 flag(route(j)) = 0
    
23.                 r = r + 1: st = "": dis = 0
    
24.                 For k = 1 To j
    
25.                   st = IIf(st = "", arr(route(k) + 1, 1), st & "-" & arr(route(k) + 1, 1))
    
26.                   If k > 1 Then dis = dis + matrix(route(k), route(k - 1))
    
27.                 Next
    
28.                 Sheet1.Cells(r, 4) = st: Sheet1.Cells(r, 3) = dis
    
29.                 Sheet1.Cells(r, 1) = "E": Sheet1.Cells(r, 2) = "B"
    
30.                 route(j) = 0
    
31.                 j = j - 1
    
32.             Else
    
33.                 flag(i) = 1
    
34.                 If route(j) > 0 Then flag(route(j)) = 0
    
35.                 route(j) = i
    
36.                 j = j + 1
    
37.             End If
    
38.         Else
    
39.             If route(j) > 0 Then flag(route(j)) = 0
    
40.             route(j) = 0
    
41.             j = j - 1
    
42.         End If
    
43.     Loop
    
44. End Sub
    

复制代码

小花鹿

看看谁的行数最少，呵呵

paciguard

高手太多，有人可以不用递归，有人可以不用字典，学习学习！！！

香川群子

小花鹿 发表于 2017-12-21 12:55
看看谁的行数最少，呵呵

肯定是用递归行数最少。

1. Dim dic, jg(), k, t3
   
2. Sub test2() 'by kagawa 2017/12/2   
   
3.     ar = Sheet2.[a1].CurrentRegion '读取A1区域数据
   
4.     m = UBound(ar) '最大行数   
   
5.     Set dic = CreateObject("Scripting.Dictionary") '建立字典
   
6.     For i = 2 To m '遍历原始数据
   
7.         t1 = ar(i, 1): t2 = ar(i, 2)
   
8.         dic(t1) = dic(t1) & " " & t2 '记录路径关系
   
9.         dic(t2) = dic(t2) & " " & t1 '记录路径关系
   
10.         dic(t1 & "-" & t2) = ar(i, 3) '记录路径关系对应距离
    
11.         dic(t2 & "-" & t1) = ar(i, 3) '记录路径关系对应距离
    
12.     Next   
    
13.     t1 = [a2] '"E" '输入起点位置
    
14.     t3 = [b2] '"B" '输入终点位置   
    
15.     ReDim jg(m, 2) '定义存放结果的数组jg()
    
16.     k = 0: Call dg(0, "-" & t1 & "-", t1, 1)   
    
17.     [a1].CurrentRegion.Offset(1, 2) = ""
    
18.     [c2].Resize(k, 3) = jg '输出有效路径以及累计路程
    
19.     r = WorksheetFunction.Min([c2].Resize(k)) '最短路程
    
20.     MsgBox "找到 " & k & " 条有效路径," & vbCr & "最短路程 = " & r
    
21. End Sub
    
22. Sub dg(r, s, t, l) '路程r,路径s,节点t,搜索层数l
    
23.     tr = Split(dic(t)) '根据字典提取节点t1的关联节点集合tr
    
24.     For j = 1 To UBound(tr) '遍历关联节点总数n
    
25.         t2 = tr(j) '提取关联节点t2
    
26.         If InStr(s, "-" & t2 & "-") = 0 Then '如果路径中不含这个节点
    
27.             If t2 = t3 Then '如果已到终点t3
    
28.                 jg(k, 0) = r + dic(t & "-" & t2) '输出累计路程
    
29.                 jg(k, 1) = l '搜索层数
    
30.                 jg(k, 2) = Mid(s & t2, 2) '输出路径
    
31.                 k = k + 1 '有效路径数k
    
32.             Else '未到终点时记录新的过程路径
    
33.                 Call dg(r + dic(t & "-" & t2), s & t2 & "-", t2, l + 1)'更新并向下深度搜索
    
34.             End If
    
35.         End If
    
36.     Next
    
37. End Sub

复制代码