ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 蓝桥玄霜

[Excel 程序开发] 【已总结】[第119期]假如你是无人驾驶车上的电脑,你想好了怎么走吗?

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2017-12-8 12:49 | 显示全部楼层
一个点允许经过两次吗?比如e-f-a-tk1-tk3-a-b,a点经过了两次,这算是从e到b的一条路径吗?
还是每个点只能经过一次?

TA的精华主题

TA的得分主题

发表于 2017-12-8 14:23 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  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
复制代码


老师辛苦

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-11 15:04 | 显示全部楼层
本帖最后由 尽情飞舞 于 2017-12-12 10:45 编辑

  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. Sub driverless()
  4.     ShortcutMileage = 10000
  5.    
  6.     Dim arr, i As Long, j As Long
  7.     With Worksheets("题目")
  8.         arr = .[a1].CurrentRegion
  9.         For i = 2 To UBound(arr)'用字典嵌套求出每个站点可以通往哪些不同的站点
  10.             For j = 1 To 2
  11.                 If Not dic.Exists(arr(i, j)) Then
  12.                     Set dic(arr(i, j)) = New Dictionary
  13.                 End If
  14.             Next
  15.             dic(arr(i, 1))(arr(i, 2)) = arr(i, 3)'字典value储存相应路径的距离
  16.             dic(arr(i, 2))(arr(i, 1)) = arr(i, 3)
  17.         Next
  18.         Erase arr
  19.         
  20.         Call digui(0, dic("E").Keys, "E", "E", 0)

  21.     End With
  22.         
  23.     With Worksheets("Sheet1")
  24.         .[c2].Resize(1000, 2).Clear
  25.         .[c2].Resize(ResultCounter, 2) = Result
  26.     End With
  27.    
  28.     MsgBox "最短路径为" & Shortcut & ",长" & ShortcutMileage & "公里"
  29.    
  30.     Set dic = Nothing
  31.     ResultCounter = 0
  32.     Erase Result
  33.     ShortcutMileage = 0
  34.    
  35. End Sub


  36. Sub digui(x, stops, str, starts, mileages)
  37. 'x遍历站点,stops为当前站点所连接的所有站点,str为当前路径,starts为当前出发站,mileages为当前路径总长
  38.     If InStr(str, stops(x)) = 0 Then'如果路径str尚未经过站点stops(x),则判断该站点是否B,如果是写入结果数组,否则写入当前路径
  39.         If stops(x) = "B" Then
  40.             ResultCounter = ResultCounter + 1
  41.             Result(ResultCounter, 2) = str & "-" & stops(x)
  42.             Result(ResultCounter, 1) = mileages + dic(starts)(stops(x))
  43.             If Result(ResultCounter, 1) < ShortcutMileage Then'判断该路径是否最短路径
  44.                 ShortcutMileage = Result(ResultCounter, 1)
  45.                 Shortcut = Result(ResultCounter, 2)
  46.             End If
  47.         Else
  48.             Call digui(0, dic(stops(x)).Keys, str & "-" & stops(x), stops(x), mileages + dic(starts)(stops(x)))
  49.         End If
  50.     End If
  51.     If x < UBound(stops) Then'如果当前站点为B或者为终点,则连接下一可能站点
  52.         Call digui(x + 1, stops, str, starts, mileages)
  53.     End If
  54. End Sub
复制代码


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-13 14:05 | 显示全部楼层
本帖最后由 怪兽不乖丨Si 于 2017-12-13 14:17 编辑
  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. Sub main()
  11. Dim now As Integer
  12. StationStart = ThisWorkbook.Sheets("sheet1").Cells(2, 1)            '定义起点
  13. StationEnd = ThisWorkbook.Sheets("sheet1").Cells(2, 2)              '定义终点
  14. With ThisWorkbook.Sheets("题目")                                    '读取道路数据
  15.     LineNumber = .Cells(Rows.Count, 1).End(xlUp).Row - 1
  16.     LineMine = Range(.Cells(2, 1), .Cells(LineNumber * 2 + 1, 3))   '正向
  17.     For i = 1 To LineNumber                                         '反向
  18.         LineMine(LineNumber + i, 1) = .Cells(i + 1, 2)
  19.         LineMine(LineNumber + i, 2) = .Cells(i + 1, 1)
  20.         LineMine(LineNumber + i, 3) = .Cells(i + 1, 3)
  21.     Next
  22. End With
  23. PathNum = WorksheetFunction.Fact(LineNumber - 2) / WorksheetFunction.Fact(0)
  24. ReDim PathMine(1 To PathNum, 1 To 2) As Variant                     '记录路径,第一维为编号,第二维1记录路径,2记录长度
  25. PathNew = 1                                                         '新路径编号
  26. now = PathNew                                                       '为了迭代,设立个中间变量
  27. Call PathAdd(now)                                                   '迭代过程,筛选,在路径中添加节点
  28. a = 2                                                               '输出结果部分
  29. With ThisWorkbook.Sheets("sheet1")
  30.     For p = 1 To PathNew
  31.         If Right(PathMine(p, 1), Len(PathMine(p, 1)) - InStrRev(PathMine(p, 1), "-")) = StationEnd Then
  32.             .Cells(a, 3) = PathMine(p, 2)
  33.             .Cells(a, 4) = PathMine(p, 1)
  34.             a = a + 1
  35.         End If
  36.     Next
  37. End With
  38. Call SortMain                                                       '排序
  39. End Sub

  40. Sub PathAdd(n)   '
  41. Dim StationNow As String
  42. Dim pi As Integer
  43. Dim now As Integer
  44. Dim FirstOrNot As Boolean
  45. Dim Pathnow(1 To 2) As Variant
  46. FirstOrNot = True                                                   '新增路径判断变量
  47. If PathMine(n, 1) = "" Then                                         '找到目前路径最后一个节点
  48.     PathMine(n, 1) = StationStart
  49.     StationNow = StationStart
  50. Else
  51.     StationNow = Right(PathMine(n, 1), Len(PathMine(n, 1)) - InStrRev(PathMine(n, 1), "-"))
  52. End If
  53. If StationNow = StationEnd Then                                     '判断最终路径是否为终点
  54.     Exit Sub
  55. Else
  56.     Pathnow(1) = PathMine(n, 1)
  57.     Pathnow(2) = PathMine(n, 2)
  58.     For pi = 1 To LineNumber * 2
  59.         If LineMine(pi, 1) = StationNow Then                        '循环检索以最终节点为起点的道路
  60.             If InStr(Pathnow(1), LineMine(pi, 2)) = 0 Then          '判断道路是否重复
  61.                 If FirstOrNot = True Then                           '判断是否需要新增路径
  62.                     now = n
  63.                     PathMine(now, 1) = Pathnow(1) & "-" & LineMine(pi, 2)   '在路径中新增节点
  64.                     PathMine(now, 2) = Pathnow(2) + LineMine(pi, 3)         '增加路径长度
  65.                     Call PathAdd(now)                               '迭代过程,继续检索下一个节点
  66.                     FirstOrNot = False
  67.                 Else
  68.                     PathNew = PathNew + 1
  69.                     now = PathNew
  70.                     PathMine(now, 1) = Pathnow(1) & "-" & LineMine(pi, 2)
  71.                     PathMine(now, 2) = Pathnow(2) + LineMine(pi, 3)
  72.                     Call PathAdd(now)
  73.                 End If
  74.             End If
  75.         End If
  76.     Next
  77. End If
  78. End Sub

  79. Sub SortMain()
  80. Dim rng As Range
  81. With ThisWorkbook.Worksheets("Sheet1")
  82.     Set rng = Range(.Cells(2, 3), .Cells((.Cells(.Rows.Count, 3).End(xlUp).Row), 4))
  83. End With
  84.     rng.Select
  85.     ThisWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
  86.     ThisWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1"), _
  87.         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  88.     With ThisWorkbook.Worksheets("Sheet1").Sort
  89.         .SetRange rng
  90.         .Header = xlNo
  91.         .MatchCase = False
  92.         .Orientation = xlTopToBottom
  93.         .SortMethod = xlPinYin
  94.         .Apply
  95.     End With

  96. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-18 11:11 | 显示全部楼层
本帖最后由 liulang0808 于 2017-12-18 14:34 编辑
  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.     For j = 2 To UBound(arr)
  17.         If (arr(j, 1) = "B" And arr(j, 2) = str1) Or (arr(j, 2) = "B" And arr(j, 1) = str1) Then
  18.             d("B") = arr(j, 3)

  19.             Cells(1, a) = Join(d.keys, "-")
  20.             Cells(2, a) = WorksheetFunction.Sum(d.items)
  21.             a = a + 1

  22.             d.Remove "B"
  23.         Else
  24.             If arr(j, 1) = str1 And Not d.exists(arr(j, 2)) Then
  25.                 d(arr(j, 2)) = arr(j, 3)
  26.                 dg (arr(j, 2))

  27.             Else
  28.                 If arr(j, 2) = str1 And Not d.exists(arr(j, 1)) Then
  29.                     d(arr(j, 1)) = arr(j, 3)
  30.                     dg (arr(j, 1))

  31.                 End If
  32.             End If
  33.             
  34.             
  35.         End If
  36.     Next j
  37.     d.Remove str1
  38. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-18 16:16 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 说不好 于 2017-12-20 13:49 编辑

初学者参与一下试试



  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
复制代码


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-20 02:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
最后一天看到,试试看
  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.         If i <= UBound(flag) Then
  18.             If i = UBound(flag) Then
  19.                 If route(j) > 0 Then flag(route(j)) = 0
  20.                 route(j) = i
  21.                 flag(route(j)) = 0
  22.                 r = r + 1: st = "": dis = 0
  23.                 For k = 1 To j
  24.                   st = IIf(st = "", arr(route(k) + 1, 1), st & "-" & arr(route(k) + 1, 1))
  25.                   If k > 1 Then dis = dis + matrix(route(k), route(k - 1))
  26.                 Next
  27.                 Sheet1.Cells(r, 4) = st: Sheet1.Cells(r, 3) = dis
  28.                 Sheet1.Cells(r, 1) = "E": Sheet1.Cells(r, 2) = "B"
  29.                 route(j) = 0
  30.                 j = j - 1
  31.             Else
  32.                 flag(i) = 1
  33.                 If route(j) > 0 Then flag(route(j)) = 0
  34.                 route(j) = i
  35.                 j = j + 1
  36.             End If
  37.         Else
  38.             If route(j) > 0 Then flag(route(j)) = 0
  39.             route(j) = 0
  40.             j = j - 1
  41.         End If
  42.     Loop
  43. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-21 12:55 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
看看谁的行数最少,呵呵

TA的精华主题

TA的得分主题

发表于 2017-12-21 14:13 | 显示全部楼层
高手太多,有人可以不用递归,有人可以不用字典,学习学习!!!

TA的精华主题

TA的得分主题

发表于 2017-12-21 16:27 | 显示全部楼层
小花鹿 发表于 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
复制代码

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 12:59 , Processed in 0.051434 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表