ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 5141|回复: 49

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-11-16 17:14 | 显示全部楼层 |阅读模式
本帖最后由 delete_007 于 2017-12-21 10:50 编辑

根据ABC列给出的各个地点之间的距离,如附图所示
有一辆无人驾驶车在E点,要开往B点,
假如你是无人驾驶车上的电脑,请给出E-B的所有可能的路径和距离(路径长度之和),可以决定最短的距离。
答案显示在Sheet1上面。
距离写法:190   路径写法:E-TK03-TK01-B


竞赛日期:2017年11月17日 至 2017年12月20日
答题请用CODE模式贴出代码,并压缩上传EXCEL附件。
时间过得很快,今天12月21日了,这次参加的人数比较多,有19人参加,基本上都得分了,谢谢大家的支持。
大家都有体会:在本论坛获得技术分的机会不多,而且题目大都比较难,这次有人说题目简单了,是送分题,我觉得这次的题目比较应景,呵呵。
能够完成的得2分,是VBA水平的体现,恭喜了。
我的代码不及大家的,我比较欣赏2楼的代码:简洁高效。
  1. '编程思路:
  2. '把已知条件中开始点和结束点都放入字典;可使得从任何一点出发,都可以求得结束点的距离
  3. '用路径来控制去除走重复路线的点;
  4. '2017-11-6

  5. Dim Arr, d, k, t, i&
  6. Dim r%, Arr1()    '计算结果动态数组
  7. Dim w, nn%          'w 递归次数
  8. Dim Sn%, s()    '路径动态数组
  9. Sub lqxs_zd()
  10. Dim Brr, ks$, js$, js1$, m&, cw
  11. Dim x$, y$, j&, JL, kk, tt
  12. Set d = CreateObject("Scripting.Dictionary")
  13. Sheet1.Activate
  14. [c2:dz500].ClearContents
  15. Arr = [a1].CurrentRegion
  16. Brr = Sheet2.[a1].CurrentRegion
  17. For i = 2 To UBound(Brr)
  18.     x = Brr(i, 1): y = Brr(i, 2)
  19.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
  20.     d(x)(y) = Brr(i, 3)
  21.     y = Brr(i, 1): x = Brr(i, 2)
  22.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
  23.     d(x)(y) = Brr(i, 3)
  24. Next
  25. k = d.keys: t = d.items
  26. For i = 2 To UBound(Arr)
  27.     ks = Arr(i, 1): js = Arr(i, 2)  '开始点,结束点
  28.     Sn = 0: r = 0: cw = 0: w = 0: nn = 0
  29.     Sn = Sn + 1
  30.     ReDim Preserve s(1 To Sn)      '路径数组
  31.     s(Sn) = ks
  32.    
  33.     '*****************************
  34.     '判断字典中是否存在开始点和结束点数据
  35.     If Not d.exists(ks) Then
  36.         Arr(i, 3) = "已知数据中没有" & ks & "这个地点。": cw = 1
  37.     End If
  38.     If Not d.exists(js) Then
  39.         Arr(i, 3) = Arr(i, 3) & " 已知数据中没有" & js & "这个地点。": cw = 1
  40.     End If
  41.     If cw = 1 Then GoTo 200
  42.     '*****************************
  43.    
  44.     m = Application.Match(ks, k, 0) - 1
  45.     kk = d(ks).keys: tt = d(ks).items
  46.     If t(m).Count = 1 Then
  47.         js1 = kk(0): JL = tt(0) '  'JL 距离
  48.         Sn = Sn + 1
  49.         ReDim Preserve s(1 To Sn)
  50.         s(Sn) = s(Sn - 1) & "-" & js1 's(Sn)  第Sn个路径
  51.         Call did(Sn, js1, js, JL, i): w = w + 1
  52.     Else
  53.         For j = 0 To UBound(kk)
  54.             js1 = kk(j): w = 0
  55.             If InStr(s(Sn), js1) Then GoTo 100   '中间节点出现在路径中说明该点不是要求的方向
  56.             JL = tt(j)
  57.             Sn = Sn + 1
  58.             ReDim Preserve s(1 To Sn)
  59.             s(Sn) = s(Sn - 1) & "-" & js1 's(Sn)  第Sn个路径
  60.             If js = js1 Then                '如果中间节点=结束点,赋值给动态数组Arr1
  61.                 r = r + 1
  62.                 ReDim Preserve Arr1(1 To 2, 1 To r)
  63.                 Arr1(1, r) = s(Sn): Arr1(2, r) = JL: Sn = Sn - 1 '回到上一个路径
  64.             Else
  65.                 Call did(Sn, js1, js, JL, i): w = w + 1
  66.             End If
  67. 100:
  68.             If w > 0 Then nn = nn - 1: Sn = Sn - 1
  69.         Next
  70.     End If
  71.     If r > 0 Then
  72.         For j = 1 To r
  73.             Cells(j + 1, 3) = Arr1(2, j): Cells(j + 1, 4) = Arr1(1, j)
  74.         Next
  75.     End If
  76. 200:
  77. Next
  78. MsgBox "OK"
  79. End Sub

  80. Sub did(Sn, js1, js, JL, i)
  81. Dim m&, kk, tt, jl1$, js2$, ii&, a%
  82. m = Application.Match(js1, k, 0) - 1
  83. If t(m).Count > 1 Then
  84.     kk = d(js1).keys: tt = d(js1).items
  85.     For ii = 0 To UBound(kk)
  86.         w = 0
  87.         jl1 = JL: nn = Sn '- 1
  88.         js2 = kk(ii)
  89.         If InStr(s(nn), js2) Then GoTo 100  '结束点出现在路径中说明该点不是要求的方向
  90.         jl1 = jl1 + tt(ii)
  91.         nn = nn + 1
  92.         ReDim Preserve s(1 To nn)
  93.         s(nn) = s(nn - 1) & "-" & js2 's(sn)  第nn个路径
  94.         If js = js2 Then
  95.             r = r + 1
  96.             ReDim Preserve Arr1(1 To 2, 1 To r)
  97.             Arr1(1, r) = s(nn): Arr1(2, r) = jl1: nn = nn - 1
  98.             jl1 = jl1 - tt(ii)
  99.         Else
  100.             Call did(nn, js2, js, jl1, i): w = w + 1
  101.         End If
  102. 100:
  103.         If w > 0 Then nn = nn - 1 ': w = 0
  104.     Next
  105. Else
  106.     kk = d(js1).keys: tt = d(js1).items
  107.     js1 = kk(0)
  108.     If InStr(s(nn), js1) Then
  109.         a = InStrRev(s(nn), "-")
  110.         s(nn) = Left(s(nn), a - 1)
  111.         JL = JL - tt(0)
  112.         Exit Sub
  113.     End If
  114. End If
  115. End Sub
复制代码



本帖子中包含更多资源

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

x

评分

参与人数 7财富 +50 鲜花 +13 技术 +2 收起 理由
wyl0205 + 2
dear_leslie + 2
delete_007 + 50 + 2
唐伯狼 + 2
aoe1981 + 3 好题,再难就不会了。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-16 22:15 | 显示全部楼层
这几天刚才楼主那学到的

本帖子中包含更多资源

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

x

评分

参与人数 5财富 +20 鲜花 +7 技术 +2 收起 理由
临时用用的 + 1
swuso + 2 太强大了
wyl0205 + 2 太强大了
jorrui111 + 2
蓝桥玄霜 + 20 第一天就开张了,赞!

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-18 14:41 | 显示全部楼层
本帖最后由 aoe1981 于 2017-11-18 23:28 编辑

  老师,给您发消息您不回,我按我的理解做完了,如果有问题,烦您提前通知下,我思考修改。
  代码如下:
  1. Option Explicit
  2. Dim brr(), qd$, zd$, m&, jg(1 To 9999, 1 To 2), k%
  3. Sub LuJing()
  4.     Sheet1.Range("c2:d" & Rows.Count).ClearContents
  5.     Dim arr(), i&
  6.     arr = Sheet2.Range("a2:c13").Value
  7.     m = UBound(arr())
  8.     brr = Application.Transpose(arr)
  9.     ReDim Preserve brr(1 To UBound(arr(), 2), 1 To m * 2)
  10.     brr = Application.Transpose(brr)
  11.     For i = 1 To m
  12.         brr(m + i, 1) = arr(i, 2): brr(m + i, 2) = arr(i, 1): brr(m + i, 3) = arr(i, 3)
  13.     Next i
  14.     m = UBound(brr(), 1)
  15.     qd = Sheet1.Range("a2").Value: zd = Sheet1.Range("b2").Value
  16.     Call DG(qd, qd, 0)
  17.     Sheet1.Range("c2").Resize(k, 2).Value = jg()
  18.     End '释放全局变量,防止重复点击重复记录
  19. End Sub
  20. Sub DG(dian, lu, jl)
  21.     Dim j&, crr(), n&
  22.     ReDim crr(1 To m, 1 To 3)
  23.     For j = 1 To m '筛选当前点的下一步路径
  24.         If brr(j, 1) = dian Then n = n + 1: crr(n, 1) = brr(j, 1): crr(n, 2) = brr(j, 2): crr(n, 3) = brr(j, 3)
  25.     Next j
  26.     For j = 1 To UBound(crr, 1)
  27.         If crr(j, 2) = "" Then lu = Replace(lu, "-" & crr(j - 1, 1), ""): jl = jl - crr(j - 1, 3): Exit Sub '某一点遍历完后取消连接返回上一点
  28.         If InStr(lu, crr(j, 2)) = 0 Then '形成圈时取消连接,否则继续向下连接
  29.             lu = lu & "-" & crr(j, 2)
  30.             jl = jl + crr(j, 3)
  31.             If crr(j, 2) <> zd Then
  32.                 Call DG(crr(j, 2), lu, jl)
  33.             Else '到达终点时记录并退出
  34.                 k = k + 1: jg(k, 2) = lu: lu = Replace(lu, "-" & crr(j, 2), ""): jg(k, 1) = jl: jl = jl - crr(j, 3)
  35.             End If
  36.         End If
  37.     Next j
  38. End Sub
复制代码
  附件如下:
  

  修改后的代码如下(以上附件同步更新):
  1. Option Explicit
  2. Dim brr(), qd$, zd$, m&, jg(1 To 9999, 1 To 2), k&
  3. Sub LuJing()
  4.     Sheet1.Range("c2:e" & Rows.Count).ClearContents
  5.     Dim arr(), i&
  6.     arr = Sheet2.Range("a2:c13").Value
  7.     m = UBound(arr)
  8.     brr = Application.Transpose(arr)
  9.     ReDim Preserve brr(1 To UBound(arr, 2), 1 To m * 2)
  10.     brr = Application.Transpose(brr)
  11.     For i = 1 To m
  12.         brr(m + i, 1) = arr(i, 2): brr(m + i, 2) = arr(i, 1): brr(m + i, 3) = arr(i, 3)
  13.     Next i
  14.     m = UBound(brr, 1)
  15.     qd = Sheet1.Range("a2").Value: zd = Sheet1.Range("b2").Value
  16.     If qd <> zd Then Call DG(qd, qd, 0) Else k = 1: jg(k, 1) = 0: jg(k, 2) = qd & "-" & zd
  17.     Sheet1.Range("c2").Resize(k, 2).Value = jg()
  18.     End '释放全局变量,防止重复点击重复记录
  19. End Sub
  20. Sub DG(dian, lu, jl)
  21.     Dim j&, crr(), n&
  22.     ReDim crr(1 To m, 1 To 3)
  23.     For j = 1 To m '筛选当前点的下一步路径
  24.         If brr(j, 1) = dian Then n = n + 1: crr(n, 1) = brr(j, 1): crr(n, 2) = brr(j, 2): crr(n, 3) = brr(j, 3)
  25.     Next j
  26.     For j = 1 To UBound(crr, 1)
  27.         If crr(j, 2) = "" Then Exit Sub '某一点遍历完后返回上一点
  28.         If InStr(lu, crr(j, 2)) = 0 Then '形成圈时取消连接,否则继续向下连接
  29.             lu = lu & "-" & crr(j, 2)
  30.             jl = jl + crr(j, 3)
  31.             If crr(j, 2) <> zd Then
  32.                 Call DG(crr(j, 2), lu, jl)
  33.             Else '到达终点时记录路径和距离
  34.                 k = k + 1: jg(k, 2) = lu: jg(k, 1) = jl
  35.             End If
  36.             lu = Replace(lu, "-" & crr(j, 2), ""): jl = jl - crr(j, 3)'下一点递归调用后未找到路径时(遍历后都形成圈且未达终点),返回本层执行取消连接操作;本层到达终点后取消最后一步连接,继续寻找新的路径
  37.         End If
  38.     Next j
  39. End Sub
复制代码


本帖子中包含更多资源

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

x

点评

用递归了,竟然也是dg,我也是用的dg  发表于 2017-12-21 10:53

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-11-20 21:58 | 显示全部楼层
上次测试了求树任意结点路径,发现按父结点往根双向收敛比简单按结点所连边穷举搜索效果高多了,这几天琢磨怎样按树的结构来求有回路的图路径,似乎有点眉目。我的思路是,任一选一点为根,先构建一棵树(由N个结点和N-1条边),剩余边做为连枝。将每一连枝与两点在树中路径构成回路做互赋父结点处理。依然换父结点往根双向收敛求任两点路径,只是这次父结点不是唯一的了。在本次汽车寻路中基本实现实找出全部路径,只是如果根点不为要搜索的两点时,因为求路径过程有减枝操作,所遍历的路径有重复的,用字典筛一下就行了。(根如设为要搜索的两点中的任一个都不会有重复,因为这时没有减枝)。刚学不久,代码没有优化。
  1. <p>Option Explicit
  2. Dim DicEdge, DicNode, ArrPath(), r&</p><p>Sub MyMain()
  3.     Dim i&, j&, x$, y$, Arr, NumNode%, b(), s, k, t, d
  4.     Set DicEdge = CreateObject("Scripting.Dictionary")
  5.     Set DicNode = CreateObject("Scripting.Dictionary")
  6.     Set d = CreateObject("Scripting.Dictionary")
  7.     [c2:d1000].ClearContents
  8.     Arr = Sheets("&Igrave;&acirc;&Auml;&iquest;").[a1].CurrentRegion
  9.     For i = 2 To UBound(Arr)
  10.         x = Arr(i, 1) & Arr(i, 2): y = Arr(i, 2) & Arr(i, 1)
  11.         If DicEdge.exists(x) = False Then DicEdge(x) = Arr(i, 3)
  12.         If DicEdge.exists(y) = False Then DicEdge(y) = Arr(i, 3)
  13.         If DicNode.exists(Arr(i, 1)) = False Then DicNode(Arr(i, 1)) = ""
  14.         If DicNode.exists(Arr(i, 2)) = False Then DicNode(Arr(i, 2)) = ""
  15.     Next
  16.     NumNode = DicNode.Count: DicNode.RemoveAll: r = 0: ReDim b(1 To UBound(Arr) - NumNode): ReDim ArrPath(1 To 1)
  17.     Call CreatSimpleTree(Arr, [b2].Value, NumNode)
  18.     For i = NumNode + 1 To UBound(Arr)
  19.         r = 0
  20.         Call LSearch(Arr(i, 1), Arr(i, 2), "")
  21.         b(i - NumNode) = ArrPath(1)
  22.     Next
  23.     Call CreateComplexTree(b)
  24.     r = 0
  25.     Call LSearch([a2].Value, [b2].Value, "")
  26.     For i = 1 To UBound(ArrPath)
  27.         If d.exists(ArrPath(i)) = False Then d(ArrPath(i)) = Array(0, ArrPath(i))
  28.     Next
  29.     t = d.items
  30.     For i = 0 To UBound(t)
  31.         s = Split(t(i)(1), "-")
  32.         For j = 0 To UBound(s) - 1
  33.             t(i)(0) = t(i)(0) + DicEdge(s(j) & s(j + 1))
  34.         Next
  35.     Next
  36.     [c2].Resize(d.Count, 2) = Application.Transpose(Application.Transpose(t))
  37.     [c2].Resize(d.Count, 2).Sort ([c2])
  38.     Columns("C:D").AutoFit
  39. End Sub</p><p>Sub CreatSimpleTree(ByRef a, ByVal RootNode$, ByVal n%)
  40.     Dim i%, j%, k%, m%, temp, b()
  41.     a(1, 1) = RootNode: a(1, 2) = RootNode: a(1, 3) = 0:  DicNode(RootNode) = Array(RootNode)
  42.     k = 1: m = 1
  43.     Do
  44.         For i = m + 1 To UBound(a)
  45.             If (a(i, 1) = a(k, 1) And Not DicNode.exists(a(i, 2))) Or (a(i, 2) = a(k, 1) And Not DicNode.exists(a(i, 1))) Then
  46.                 m = m + 1
  47.                 If a(i, 1) = a(k, 1) Then
  48.                     temp = a(i, 1): a(i, 1) = a(i, 2): a(i, 2) = temp:
  49.                 End If
  50.                 If i > m Then
  51.                     For j = 1 To 3
  52.                         temp = a(m, j): a(m, j) = a(i, j): a(i, j) = temp
  53.                     Next
  54.                 End If
  55.                 DicNode(a(m, 1)) = Array(a(m, 2))
  56.             End If
  57.         Next
  58.         k = k + 1
  59.     Loop Until m >= n
  60. End Sub</p><p>Sub LSearch(ByVal node1$, ByVal node2$, ByVal StrL$)
  61.     Dim i%, j%, m%, Nstr$, Nnode$, s
  62.     If node1 = node2 Then
  63.         Nstr = StrL & node2
  64.         r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
  65.     Else
  66.         If DicNode(node1)(0) = node1 Then
  67.             Nstr = StrL & node1 & "-"
  68.             Call RSearch(node1, node2, Nstr, "")
  69.         Else
  70.             For i = 0 To UBound(DicNode(node1))
  71.                 Nnode = DicNode(node1)(i)
  72.                 If InStr(StrL, Nnode) = 0 Then
  73.                     Nstr = StrL & node1 & "-"
  74.                     Call LSearch(Nnode, node2, Nstr)
  75.                 End If
  76.             Next
  77.         End If
  78.     End If
  79. End Sub</p><p>Sub RSearch(ByVal node1$, ByVal node2$, ByVal StrL$, ByVal StrR$)
  80.     Dim i%, Nstr$, Nnode$
  81.     If node2 = node1 Then
  82.         Nstr = StrL & node2 & StrR
  83.         r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
  84.     Else
  85.         For i = 0 To UBound(DicNode(node2))
  86.             Nnode = DicNode(node2)(i)
  87.             If InStr(StrL, Nnode) = 0 Then
  88.                 If InStr(StrR, Nnode) = 0 Then
  89.                     Nstr = "-" & node2 & StrR
  90.                     Call RSearch(node1, Nnode, StrL, Nstr)
  91.                 End If
  92.             Else
  93.                 Nstr = Split(Replace(StrL, Nnode, "|"), "|")(0)
  94.                 Nstr = Nstr & Nnode & "-" & node2 & StrR
  95.                 r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
  96.             End If
  97.         Next
  98.     End If
  99. End Sub</p><p>Sub CreateComplexTree(ByRef a())
  100. Dim i%, j%, s, b(), m%, n%
  101.     For i = 1 To UBound(a)
  102.         s = Split(a(i), "-")
  103.         For j = 0 To UBound(s)
  104.             b = DicNode(s(j))
  105.             m = (j + UBound(s)) Mod (UBound(s) + 1)
  106.             If Application.IsError(Application.Match(s(m), b, 0)) Then
  107.                 n = UBound(b) + 1
  108.                 ReDim Preserve b(n)
  109.                 b(n) = s(m)
  110.                 DicNode(s(j)) = b
  111.             End If
  112.             m = (j + 1) Mod (UBound(s) + 1)
  113.             If Application.IsError(Application.Match(s(m), b, 0)) Then
  114.                 n = UBound(b) + 1
  115.                 ReDim Preserve b(n)
  116.                 b(n) = s(m)
  117.                 DicNode(s(j)) = b
  118.             End If
  119.         Next
  120.     Next
  121. End Sub

  122. </p><p> </p>
复制代码


本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2017-11-21 15:15 | 显示全部楼层
本帖最后由 龙城飞将III 于 2017-11-22 12:04 编辑
  1. Public dicPath As Variant
  2. Sub Path()
  3.         t = Timer
  4.         Dim strStartNode As String
  5.         Dim strEndNode As String
  6.         Dim arrPathTemp As Variant
  7.         Dim arrPath As Variant
  8.         Dim strPath As String
  9.         Dim dbDistence As Double
  10.         Dim arrResult As Variant
  11.         
  12.         Set dicPath = CreateObject("scripting.dictionary")
  13.         strStartNode = Sheet1.Cells(2, "A")
  14.         strEndNode = Sheet1.Cells(2, "B")
  15.         arrPathTemp = Sheet2.Range("A2:C13")
  16.         ReDim arrPath(1 To 2 * UBound(arrPathTemp, 1), 1 To UBound(arrPathTemp, 2))
  17.         For i = 1 To 2 * UBound(arrPathTemp, 1)
  18.                 If i <= UBound(arrPathTemp) Then
  19.                         arrPath(i, 1) = arrPathTemp(i, 1)
  20.                         arrPath(i, 2) = arrPathTemp(i, 2)
  21.                         arrPath(i, 3) = arrPathTemp(i, 3)
  22.                 Else
  23.                         arrPath(i, 1) = arrPathTemp(i - UBound(arrPathTemp, 1), 2)
  24.                         arrPath(i, 2) = arrPathTemp(i - UBound(arrPathTemp, 1), 1)
  25.                         arrPath(i, 3) = arrPathTemp(i - UBound(arrPathTemp, 1), 3)
  26.                 End If

  27.         Next

  28.         For m = 1 To UBound(arrPath)
  29.                 If arrPath(m, 1) = strStartNode Then
  30.                         findPath arrPath(m, 1), strEndNode, arrPath, arrPath(m, 1), 0
  31.                 End If
  32.         Next
  33.         arrResultpath = dicPath.keys
  34.         arrResultDistence = dicPath.items
  35.         ReDim arrResult(1 To dicPath.Count, 1 To 2)
  36.         For n = 1 To UBound(arrResult)
  37.                 arrResult(n, 1) = arrResultDistence(n - 1)
  38.                 arrResult(n, 2) = arrResultpath(n - 1)
  39.         Next
  40.         With Sheet1
  41.                 .Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Clear
  42.                 .Cells(2, "C").Resize(UBound(arrResult), 2) = arrResult
  43.         End With
  44.         MsgBox "耗时: " & Timer - t & "秒!"
  45. End Sub
  46. Sub findPath(StartNode, EndNode, arrPath, Path, Distence)
  47.         For i = 1 To UBound(arrPath)
  48.                 '开始点是否和要寻找路线的初始点相同
  49.                 If arrPath(i, 1) = StartNode Then
  50.                         '是否陷入循环路径
  51.                         If InStr(Path, arrPath(i, 2)) = 0 Then
  52.                                 Distence_new = Distence + arrPath(i, 3)
  53.                                 Path_new = Path & "-" & arrPath(i, 2)
  54.                                 '结束点是否是终点
  55.                                 If arrPath(i, 2) = EndNode Then
  56.                                         '结果放入字典
  57.                                         dicPath(Path_new) = Distence_new
  58.                                         Exit Sub
  59.                                 End If
  60.                                 '以结束点为初始点继续寻找路径
  61.                                 findPath arrPath(i, 2), EndNode, arrPath, Path_new, Distence_new
  62.                         End If
  63.                 End If
  64.         Next
  65. End Sub

复制代码

本帖子中包含更多资源

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

x

点评

目标接近了,加油!再给你一次机会。  发表于 2017-11-22 08:49

TA的精华主题

TA的得分主题

发表于 2017-11-21 15:15 | 显示全部楼层
本帖最后由 龙城飞将III 于 2017-12-4 19:21 编辑

重新修改:
  1. Public dicPath As Variant
  2. Sub Path()
  3.         t = Timer
  4.         Dim strStartNode As String
  5.         Dim strEndNode As String
  6.         Dim arrPathTemp As Variant
  7.         Dim arrPath As Variant
  8.         Dim strPath As String
  9.         Dim dbDistence As Double
  10.         Dim arrResult As Variant
  11.         Dim rng As Range
  12.         
  13.         Set dicPath = CreateObject("scripting.dictionary")
  14.         strStartNode = Sheet1.Cells(2, "A")
  15.         strEndNode = Sheet1.Cells(2, "B")
  16.         arrPathTemp = Sheet2.Range("A2:C13")
  17.         ReDim arrPath(1 To 2 * UBound(arrPathTemp, 1), 1 To UBound(arrPathTemp, 2))
  18.         For i = 1 To 2 * UBound(arrPathTemp, 1)
  19.                 If i <= UBound(arrPathTemp) Then
  20.                         arrPath(i, 1) = arrPathTemp(i, 1)
  21.                         arrPath(i, 2) = arrPathTemp(i, 2)
  22.                         arrPath(i, 3) = arrPathTemp(i, 3)
  23.                 Else
  24.                         arrPath(i, 1) = arrPathTemp(i - UBound(arrPathTemp, 1), 2)
  25.                         arrPath(i, 2) = arrPathTemp(i - UBound(arrPathTemp, 1), 1)
  26.                         arrPath(i, 3) = arrPathTemp(i - UBound(arrPathTemp, 1), 3)
  27.                 End If

  28.         Next

  29.         For m = 1 To UBound(arrPath)
  30.                 If arrPath(m, 1) = strStartNode Then
  31.                         findPath arrPath(m, 1), strEndNode, arrPath, arrPath(m, 1), 0
  32.                 End If
  33.         Next
  34.         arrResultpath = dicPath.keys
  35.         arrResultDistence = dicPath.items
  36.         ReDim arrResult(1 To dicPath.Count, 1 To 2)
  37.         For n = 1 To UBound(arrResult)
  38.                 arrResult(n, 1) = arrResultDistence(n - 1)
  39.                 arrResult(n, 2) = arrResultpath(n - 1)
  40.         Next
  41.         With Sheet1
  42.                 .Range(.Cells(2, "C"), .Cells(Rows.Count, "D")).Clear
  43.                 .Cells(2, "C").Resize(UBound(arrResult), 2) = arrResult
  44.         End With
  45.         MsgBox "耗时: " & Timer - t & "秒!"
  46. End Sub
  47. Sub findPath(StartNode, EndNode, arrPath, Path, Distence)
  48.         For i = 1 To UBound(arrPath)
  49.                 '开始点是否和要寻找路线的初始点相同
  50.                 If arrPath(i, 1) = StartNode Then
  51.                         '是否陷入循环路径
  52.                         If InStr(Path, arrPath(i, 2)) = 0 Then
  53.                                 Distence_new = Distence + arrPath(i, 3)
  54.                                 Path_new = Path & "-" & arrPath(i, 2)
  55.                                 '结束点是否是终点
  56.                                 If arrPath(i, 2) = EndNode Then
  57.                                         '结果放入字典
  58.                                         dicPath(Path_new) = Distence_new
  59.                                         GoTo next_
  60.                                 End If
  61.                                 '以结束点为初始点继续寻找路径
  62.                                 findPath arrPath(i, 2), EndNode, arrPath, Path_new, Distence_new
  63.                         End If
  64.                 End If
  65. next_:
  66.         Next
  67. End Sub

复制代码

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2017-11-23 10:22 | 显示全部楼层
本帖最后由 zopey 于 2017-11-23 10:23 编辑
  1. <blockquote>Sub gd_serach()
复制代码


Sub gd_serach()

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

With Sheets("题目")
For i = 2 To .[a2].End(4).Row
    If Not dic.Exists(.Cells(i, 1).Value) Then
       k = k + 1
       dic(.Cells(i, 1).Value) = k
       xm(k) = .Cells(i, 1).Value
    End If

    If Not dic.Exists(.Cells(i, 2).Value) Then
       k = k + 1
       dic(.Cells(i, 2).Value) = k
       xm(k) = .Cells(i, 2).Value
    End If
Next
End With

'[e2].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
'[f1].Resize(1, dic.Count) = dic.keys

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

For i = 1 To k
For j = 1 To k
   If i = j Then
      arr(i, j) = 0
   Else
      arr(i, j) = -1
   End If
Next
Next

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

'[f2].Resize(k, k) = Application.Transpose(arr)

'brr 权值数组,crr 标号上色
Dim brr() As Integer, crr() As Boolean, drr() As String, temp%
ReDim brr(1 To k), crr(1 To k), drr(1 To k)

For i = 1 To k
    brr(i) = arr(dic([a2].Value), i)
    drr(i) = [a2].Value
    If brr(i) = 0 Then crr(i) = True
Next

haha:
'第一步
temp = 0
For i = 1 To k
    If crr(i) = False Then
    If temp > 0 Then
       If brr(i) > 0 And brr(i) < temp Then temp = brr(i)
    Else
       If brr(i) > 0 Then temp = brr(i)
    End If
    End If
Next

For i = 1 To k
   If brr(i) = temp Then crr(i) = True: drr(i) = drr(i) & "-" & xm(i)
Next

'第二步
For i = 1 To k
If brr(i) = temp Then
   For j = 1 To k
   If crr(j) = False Then
      If arr(i, j) > 0 Then
         If brr(j) = -1 Then
            brr(j) = temp + arr(i, j): drr(j) = drr(i)
         Else
            If brr(j) > temp + arr(i, j) Then brr(j) = temp + arr(i, j): drr(j) = drr(i)
         End If
      End If
   End If
   Next
End If
Next

'[f15].Resize(1, k) = brr
'[f16].Resize(1, k) = crr
'[f17].Resize(1, k) = drr

'MsgBox temp

If crr(dic([b2].Value)) = False Then GoTo haha


[c2] = brr(dic([b2].Value))
[d2] = drr(dic([b2].Value))

End Sub

本帖子中包含更多资源

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

x

点评

请仔细理解题目的要求,不是要最短距离。现在还有时间,请继续。  发表于 2017-11-27 16:55

TA的精华主题

TA的得分主题

发表于 2017-11-24 08:50 | 显示全部楼层
  1. Dim sj, jg(), d, N&
  2. Sub delete_007()
  3.     Dim i&, stPoint$, endPoint$, m&, T
  4.     T = Timer                                       '记录程序运行时间
  5.     Set d = CreateObject("scripting.dictionary")    '新建字典对象,用于存储各点间的距离
  6.     sj = Sheet2.Range("A1").CurrentRegion           '取得各点间距离信息
  7.     For i = 2 To UBound(sj)
  8.         If Not d.exists(sj(i, 1)) Then Set d(sj(i, 1)) = CreateObject("scripting.dictionary")
  9.         If Not d.exists(sj(i, 2)) Then Set d(sj(i, 2)) = CreateObject("scripting.dictionary")
  10.         d(sj(i, 1))(sj(i, 2)) = sj(i, 3)            '将各点信息存入字典,以备后续调用
  11.         d(sj(i, 2))(sj(i, 1)) = sj(i, 3)
  12.     Next i
  13.     With Sheet1
  14.         m = .Range("A1").End(xlDown).Row            '取得待求解页最后一行行号,可同时计算多个开始、结束点
  15.         sj = .Range("A1").Resize(m, 2)
  16.         .Range("A1").CurrentRegion.Offset(1, 2).ClearContents       '清空已有结果
  17.         For i = 2 To m                              '逐行求解
  18.             N = 0                                   '初始化
  19.             Erase jg
  20.             stPoint = sj(i, 1)                      '起始点
  21.             endPoint = sj(i, 2)                     '结束点
  22.             If Not d.exists(stPoint) Then
  23.                 MsgBox "起始点“" & stPoint & "”不存在!"
  24.             ElseIf Not d.exists(endPoint) Then
  25.                 MsgBox "终点“" & endPoint & "”不存在!"
  26.             Else
  27.                 Call digui(stPoint, endPoint, stPoint, 0)           '递归求解
  28.                 .Range("C1").Offset(i - 1, 0).Resize(1, 2 * N) = jg '输出结果
  29.             End If
  30.         Next i
  31.     End With
  32.     Set d = Nothing
  33.     MsgBox " Time: " & Format(Timer - T, "0.000s")                  '输出程序运行时间
  34. End Sub
  35. Sub digui(stp, endp, path$, distanse#)              '起始点,结束点,路径,距离
  36.     Dim j&, key
  37.     key = d(stp).keys                               '取得起始点各个分支节点
  38.     For j = 0 To UBound(key)                        '循环各分支节点
  39.         If key(j) = endp Then                       '当分支节点为终点时输出结果
  40.             N = N + 1
  41.             ReDim Preserve jg(1 To N * 2)
  42.             jg(2 * N) = path & "-" & endp
  43.             jg(2 * N - 1) = distanse + d(stp)(endp)
  44.         ElseIf InStr("-" & path & "-", "-" & key(j) & "-") = 0 Then     '判断分支节点是否已经在前面经过,避免循环往复
  45.             Call digui(key(j), endp, path & "-" & key(j), distanse + d(stp)(key(j)))    '以该分支节点作为起始点,递归寻求下一个节点
  46.         End If
  47.     Next j
  48. End Sub
复制代码


初学递归,试着交一个答案。

本帖子中包含更多资源

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

x

评分

参与人数 2财富 +20 鲜花 +3 技术 +2 收起 理由
kuangben8 + 3 7神全才啊。。。
蓝桥玄霜 + 20 + 2 值得肯定,快突破100了。赞!

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-11-24 09:44 | 显示全部楼层
zopey 发表于 2017-11-23 10:22
Sub gd_serach()

Dim i%, k%, dic As Object, xm(1 To 255)

请仔细理解题目的要求,不是要最短距离。现在还有时间,请继续。

TA的精华主题

TA的得分主题

发表于 2017-11-25 02:41 | 显示全部楼层
本帖最后由 paciguard 于 2017-11-25 09:44 编辑
  1. Dim dic, St$, Ed$, Str$, Sumdis&, d, cc
  2. Sub lqxs_zd()
  3. Dim ar, jj&
  4. Set dic = CreateObject("Scripting.Dictionary")
  5. Set d = CreateObject("Scripting.Dictionary")
  6. ar = Sheet2.Range("A2:C" & Sheet2.[a65536].End(3).Row)
  7. For i = 1 To UBound(ar)
  8. dic(ar(i, 1) & "," & ar(i, 2)) = ar(i, 3)
  9. dic(ar(i, 2) & "," & ar(i, 1)) = ar(i, 3)
  10. Next i
  11. St = Sheet1.Range("A2")
  12. Ed = Sheet1.Range("B2")
  13. Do While jj <= UBound(dic.keys())
  14. If Split(dic.keys()(jj), ",")(0) = St Then
  15. cc = 0
  16. Do While cc <= UBound(dic.keys())
  17. Str = St & "-" & Split(dic.keys()(jj), ",")(1)
  18. Sumdis = dic(Replace(Str, "-", ","))
  19. Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), cc)
  20. If InStr(Str, St) > 0 And InStr(Str, Ed) > 0 Then
  21. If Not d.exists(Str) Then
  22. d.Add Str, Sumdis
  23. cc = cc + 1
  24. End If
  25. Else
  26. cc = cc + 1
  27. End If
  28. Loop
  29. End If
  30. jj = jj + 1
  31. Loop
  32. Sheet1.Range("C2").Resize(UBound(d.items()) + 1, 1) = Application.Transpose(d.items())
  33. Sheet1.Range("D2").Resize(UBound(d.keys()) + 1, 1) = Application.Transpose(d.keys())
  34. End Sub

  35. Sub Findpath(s, ii)
  36. Dim jjj&
  37. jjj = ii
  38. Dim blog
  39. If jjj >= 23 Then Exit Sub
  40. If InStr(Str, St) > 0 And InStr(Str, Ed) > 0 Then Exit Sub
  41. If Split(dic.keys()(jjj), ",")(0) = s And InStr(Str, Split(dic.keys()(jjj), ",")(1)) = 0 And InStr(Str, Ed) = 0 Then
  42. For Each keya In d
  43. If d.exists(Str & "-" & Split(dic.keys()(jjj), ",")(1) & "-" & Ed) Then
  44. jjj = jjj + 1
  45. Else
  46. Str = Str & "-" & Split(dic.keys()(jjj), ",")(1)
  47. Sumdis = Sumdis + dic(dic.keys()(jjj))
  48. jjj = 0
  49. End If
  50. Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), jjj)
  51. ElseIf Split(dic.keys()(jjj), ",")(0) = s And Split(dic.keys()(jjj), ",")(1) = t And (InStr(Str, St) = 0 And InStr(Str, Ed) = 0) Then
  52. Str = Str & "-" & Split(dic.keys()(jjj), ",")(1)
  53. Sumdis = Sumdis + dic(dic.keys()(jjj))
  54. cc = cc + 1
  55. Exit Sub
  56. Else
  57. jjj = jjj + 1
  58. Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), jjj)
  59. End If
  60. End Sub
复制代码

本帖子中包含更多资源

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

x

点评

目标接近了,加油!再给你一次机会。  发表于 2017-11-27 16:58
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-6-19 14:46 , Processed in 0.128590 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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