ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
楼主: 蓝桥玄霜

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-11-26 12:08 | 显示全部楼层
本帖最后由 袁振涛 于 2017-11-26 14:58 编辑
  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

复制代码

本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-26 13:55 | 显示全部楼层
请老师看看是否符合要求?

本帖子中包含更多资源

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

x

点评

是我批错了,对不起。  发表于 2017-11-27 17:19
目标接近了,加油!再给你一次机会。  发表于 2017-11-27 17:06

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-27 13:27 | 显示全部楼层
增加了路况功能:0修路不通行;1单向通行;2双向通行
自定义排序函数代码在附件中。
  1. Sub lqxs_zd()
  2. ks = [a2]
  3. js = [b2]

  4. R = Sheets("题目").Range("a" & Rows.Count).End(xlUp).Row
  5. arr = Sheets("题目").Range("a2:d" & R)

  6. ReDim a2rr(1 To UBound(arr) * 2, 1 To UBound(arr, 2) + 1)
  7. ReDim jilurr(1 To UBound(a2rr), 1 To 2)

  8. ii = 0
  9. For i = 1 To UBound(arr)
  10.     If arr(i, 4) > 0 Then
  11.         ii = ii + 1
  12.         a2rr(ii, 1) = arr(i, 1)
  13.         a2rr(ii, 2) = arr(i, 2)
  14.         a2rr(ii, 3) = arr(i, 3)
  15.     End If
  16.     If arr(i, 4) > 1 Then
  17.         ii = ii + 1
  18.         a2rr(ii, 1) = arr(i, 2)
  19.         a2rr(ii, 2) = arr(i, 1)
  20.         a2rr(ii, 3) = arr(i, 3)
  21.     End If
  22. Next
  23. a2rr = YjhSort0(a2rr, "a,1", "1,3")         '按开始点、距离升序

  24. juli = 0
  25. lujin = "-" & ks  '路径

  26. If ks = js Then
  27.    
  28. Else
  29.     Call chazao(ks, js, a2rr, juli, lujin, jilurr, jls)
  30. End If

  31. R = Range("c" & Rows.Count).End(xlUp).Row
  32. Range("c2:d" & R).ClearComments
  33. If jls > 0 Then
  34.     Range("c2").Resize(UBound(jilurr), 2) = jilurr
  35. Else
  36.     [c2] = ""
  37.     [d2] = "未找到路径"
  38. End If
  39.    
  40. End Sub


  41. Sub chazao(ks, js, a2rr, juli, lujin, jilurr, jls)

  42. For i = 1 To UBound(a2rr)   '可二分法提速
  43.     If ks = a2rr(i, 1) Then Exit For
  44. Next
  45. If i > UBound(a2rr) Then Exit Sub

  46. If ks = a2rr(i, 2) Then
  47.     ii = 1   '原路返回了
  48. Else
  49.     ii = 0
  50. End If
  51. Do
  52.     If a2rr(i + ii, 1) <> ks Then
  53.         Exit Do            '该点所有路径走完
  54.     End If
  55.    
  56.     If a2rr(i + ii, 2) = js Then        '找到终点
  57.         jls = jls + 1
  58.         If jls = 1 Then
  59.             jilurr(1, 1) = juli + a2rr(i + ii, 3)
  60.             jilurr(1, 2) = Mid(lujin, 2) & "-" & js
  61.         ElseIf jilurr(1, 1) > juli + a2rr(i + ii, 3) Then
  62.             jilurr(jls, 1) = jilurr(1, 1)
  63.             jilurr(jls, 2) = jilurr(1, 2)
  64.             jilurr(1, 1) = juli + a2rr(i + ii, 3)
  65.             jilurr(1, 2) = Mid(lujin, 2) & "-" & js
  66.         Else
  67.             jilurr(jls, 1) = juli + a2rr(i + ii, 3)
  68.             jilurr(jls, 2) = Mid(lujin, 2) & "-" & js
  69.         End If
  70.     Else
  71.         If Not lujin Like "*-" & a2rr(i + ii, 2) & "-*" Then    '无重复点,找下一点
  72.             ks1 = a2rr(i + ii, 2)
  73.             juli1 = juli + a2rr(i + ii, 3)
  74.             lujin1 = lujin & "-" & ks1
  75.             Call chazao(ks1, js, a2rr, juli1, lujin1, jilurr, jls)
  76.         End If
  77.     End If
  78.     ii = ii + 1
  79. Loop Until i + ii > UBound(a2rr)

  80. End Sub
复制代码


本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-28 17:46 | 显示全部楼层
  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
复制代码


本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-29 16:27 | 显示全部楼层

谢谢蓝版主,改好了。。。
  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







复制代码

TA的精华主题

TA的得分主题

发表于 2017-11-29 16:30 | 显示全部楼层
请参照附件。。。。。。。。。。

本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定。恭喜零的突破。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-30 09:08 | 显示全部楼层
  1. Sub gd_serach()
  2. Range("c2:d9999").ClearContents

  3. Dim i%, k%, dic As Object, xm(1 To 255)
  4. Set dic = CreateObject("Scripting.Dictionary")

  5. With Sheets("题目")
  6. For i = 2 To .[a2].End(4).Row
  7.     If Not dic.Exists(.Cells(i, 1).Value) Then
  8.        k = k + 1
  9.        dic(.Cells(i, 1).Value) = k
  10.        xm(k) = .Cells(i, 1).Value
  11.     End If
  12.    
  13.     If Not dic.Exists(.Cells(i, 2).Value) Then
  14.        k = k + 1
  15.        dic(.Cells(i, 2).Value) = k
  16.        xm(k) = .Cells(i, 2).Value
  17.     End If
  18. Next
  19. End With

  20. 'arr邻接矩阵
  21. Dim j%, arr() As Integer
  22. ReDim arr(1 To k, 1 To k)

  23. For i = 1 To k
  24. For j = 1 To k
  25.    If i = j Then
  26.       arr(i, j) = 0
  27.    Else
  28.       arr(i, j) = -1
  29.    End If
  30. Next
  31. Next

  32. With Sheets("题目")
  33. For i = 2 To .[a2].End(4).Row
  34.     arr(dic(.Cells(i, 1).Value), dic(.Cells(i, 2).Value)) = .Cells(i, 3).Value
  35.     arr(dic(.Cells(i, 2).Value), dic(.Cells(i, 1).Value)) = .Cells(i, 3).Value
  36. Next
  37. End With


  38. 'brr 权值数组,crr 标号上色
  39. Dim cStack As New Collection, ks%, temp%, crr() As Boolean
  40. ReDim crr(1 To k)


  41. ks = dic([a2].Value)
  42. crr(ks) = True
  43. cStack.Add ks

  44. haha:
  45. For i = temp + 1 To k
  46.     If arr(ks, i) > 0 And crr(i) = False Then
  47.        crr(i) = True: cStack.Add i
  48.        If i = dic([b2].Value) Then
  49.          Cells(n + 2, 4).Value = xm(cStack.Item(1))
  50.          For j = 2 To cStack.Count
  51.              Cells(n + 2, 4).Value = Cells(n + 2, 4).Value & "-" & xm(cStack.Item(j))
  52.              Cells(n + 2, 3).Value = Cells(n + 2, 3).Value + arr(cStack.Item(j - 1), cStack.Item(j))
  53.          Next
  54.          n = n + 1
  55.          Exit For
  56.        End If
  57.        ks = i: temp = 0: GoTo haha
  58.     End If
  59. Next

  60. temp = cStack.Item(cStack.Count): crr(temp) = False: cStack.Remove cStack.Count


  61. If cStack.Count = 0 Then
  62.     Exit Sub
  63. Else
  64.    ks = cStack.Item(cStack.Count): GoTo haha
  65. End If

  66. Set cStack = Nothing

  67. End Sub
复制代码

本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定。恭喜零的突破。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-30 16:09 | 显示全部楼层
  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
复制代码

本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 值得肯定。恭喜了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-1 16:03 | 显示全部楼层
本帖最后由 香川群子 于 2017-12-21 14:03 编辑

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

写了详细注释,但是没有定义变量,哈哈哈。因为这个是初学者能够搞定的简单算法。
代码贴一下:
  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
复制代码


本帖子中包含更多资源

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

x

评分

参与人数 1财富 +20 技术 +2 收起 理由
蓝桥玄霜 + 20 + 2 对于大侠级的就是送分了。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-12-7 11:46 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

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

GMT+8, 2019-1-22 09:52 , Processed in 0.123824 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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