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

蓝桥玄霜 · 发表于 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楼的代码：简洁高效。

'编程思路：
'把已知条件中开始点和结束点都放入字典；可使得从任何一点出发，都可以求得结束点的距离
'用路径来控制去除走重复路线的点；
'2017-11-6
Dim Arr, d, k, t, i&
Dim r%, Arr1() '计算结果动态数组
Dim w, nn% 'w 递归次数
Dim Sn%, s() '路径动态数组
Sub lqxs_zd()
Dim Brr, ks$, js$, js1$, m&, cw
Dim x$, y$, j&, JL, kk, tt
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
[c2:dz500].ClearContents
Arr = [a1].CurrentRegion
Brr = Sheet2.[a1].CurrentRegion
For i = 2 To UBound(Brr)
x = Brr(i, 1): y = Brr(i, 2)
If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
d(x)(y) = Brr(i, 3)
y = Brr(i, 1): x = Brr(i, 2)
If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
d(x)(y) = Brr(i, 3)
Next
k = d.keys: t = d.items
For i = 2 To UBound(Arr)
ks = Arr(i, 1): js = Arr(i, 2) '开始点，结束点
Sn = 0: r = 0: cw = 0: w = 0: nn = 0
Sn = Sn + 1
ReDim Preserve s(1 To Sn) '路径数组
s(Sn) = ks
'*****************************
'判断字典中是否存在开始点和结束点数据
If Not d.exists(ks) Then
Arr(i, 3) = "已知数据中没有" & ks & "这个地点。": cw = 1
End If
If Not d.exists(js) Then
Arr(i, 3) = Arr(i, 3) & " 已知数据中没有" & js & "这个地点。": cw = 1
End If
If cw = 1 Then GoTo 200
'*****************************
m = Application.Match(ks, k, 0) - 1
kk = d(ks).keys: tt = d(ks).items
If t(m).Count = 1 Then
js1 = kk(0): JL = tt(0) ' 'JL 距离
Sn = Sn + 1
ReDim Preserve s(1 To Sn)
s(Sn) = s(Sn - 1) & "-" & js1 's(Sn) 第Sn个路径
Call did(Sn, js1, js, JL, i): w = w + 1
Else
For j = 0 To UBound(kk)
js1 = kk(j): w = 0
If InStr(s(Sn), js1) Then GoTo 100 '中间节点出现在路径中说明该点不是要求的方向
JL = tt(j)
Sn = Sn + 1
ReDim Preserve s(1 To Sn)
s(Sn) = s(Sn - 1) & "-" & js1 's(Sn) 第Sn个路径
If js = js1 Then '如果中间节点=结束点，赋值给动态数组Arr1
r = r + 1
ReDim Preserve Arr1(1 To 2, 1 To r)
Arr1(1, r) = s(Sn): Arr1(2, r) = JL: Sn = Sn - 1 '回到上一个路径
Else
Call did(Sn, js1, js, JL, i): w = w + 1
End If
100:
If w > 0 Then nn = nn - 1: Sn = Sn - 1
Next
End If
If r > 0 Then
For j = 1 To r
Cells(j + 1, 3) = Arr1(2, j): Cells(j + 1, 4) = Arr1(1, j)
Next
End If
200:
Next
MsgBox "OK"
End Sub
Sub did(Sn, js1, js, JL, i)
Dim m&, kk, tt, jl1$, js2$, ii&, a%
m = Application.Match(js1, k, 0) - 1
If t(m).Count > 1 Then
kk = d(js1).keys: tt = d(js1).items
For ii = 0 To UBound(kk)
w = 0
jl1 = JL: nn = Sn '- 1
js2 = kk(ii)
If InStr(s(nn), js2) Then GoTo 100 '结束点出现在路径中说明该点不是要求的方向
jl1 = jl1 + tt(ii)
nn = nn + 1
ReDim Preserve s(1 To nn)
s(nn) = s(nn - 1) & "-" & js2 's(sn) 第nn个路径
If js = js2 Then
r = r + 1
ReDim Preserve Arr1(1 To 2, 1 To r)
Arr1(1, r) = s(nn): Arr1(2, r) = jl1: nn = nn - 1
jl1 = jl1 - tt(ii)
Else
Call did(nn, js2, js, jl1, i): w = w + 1
End If
100:
If w > 0 Then nn = nn - 1 ': w = 0
Next
Else
kk = d(js1).keys: tt = d(js1).items
js1 = kk(0)
If InStr(s(nn), js1) Then
a = InStrRev(s(nn), "-")
s(nn) = Left(s(nn), a - 1)
JL = JL - tt(0)
Exit Sub
End If
End If
End Sub

复制代码

ykytom · 发表于 2017-11-16 22:15

这几天刚才楼主那学到的

aoe1981 · 发表于 2017-11-18 14:41

本帖最后由 aoe1981 于 2017-11-18 23:28 编辑

　　老师，给您发消息您不回，我按我的理解做完了，如果有问题，烦您提前通知下，我思考修改。
　　代码如下：

Option Explicit
Dim brr(), qd$, zd$, m&, jg(1 To 9999, 1 To 2), k%
Sub LuJing()
Sheet1.Range("c2:d" & Rows.Count).ClearContents
Dim arr(), i&
arr = Sheet2.Range("a2:c13").Value
m = UBound(arr())
brr = Application.Transpose(arr)
ReDim Preserve brr(1 To UBound(arr(), 2), 1 To m * 2)
brr = Application.Transpose(brr)
For i = 1 To m
brr(m + i, 1) = arr(i, 2): brr(m + i, 2) = arr(i, 1): brr(m + i, 3) = arr(i, 3)
Next i
m = UBound(brr(), 1)
qd = Sheet1.Range("a2").Value: zd = Sheet1.Range("b2").Value
Call DG(qd, qd, 0)
Sheet1.Range("c2").Resize(k, 2).Value = jg()
End '释放全局变量，防止重复点击重复记录
End Sub
Sub DG(dian, lu, jl)
Dim j&, crr(), n&
ReDim crr(1 To m, 1 To 3)
For j = 1 To m '筛选当前点的下一步路径
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)
Next j
For j = 1 To UBound(crr, 1)
If crr(j, 2) = "" Then lu = Replace(lu, "-" & crr(j - 1, 1), ""): jl = jl - crr(j - 1, 3): Exit Sub '某一点遍历完后取消连接返回上一点
If InStr(lu, crr(j, 2)) = 0 Then '形成圈时取消连接，否则继续向下连接
lu = lu & "-" & crr(j, 2)
jl = jl + crr(j, 3)
If crr(j, 2) <> zd Then
Call DG(crr(j, 2), lu, jl)
Else '到达终点时记录并退出
k = k + 1: jg(k, 2) = lu: lu = Replace(lu, "-" & crr(j, 2), ""): jg(k, 1) = jl: jl = jl - crr(j, 3)
End If
End If
Next j
End Sub

复制代码

　　附件如下：
　　

　　修改后的代码如下（以上附件同步更新）：

Option Explicit
Dim brr(), qd$, zd$, m&, jg(1 To 9999, 1 To 2), k&
Sub LuJing()
Sheet1.Range("c2:e" & Rows.Count).ClearContents
Dim arr(), i&
arr = Sheet2.Range("a2:c13").Value
m = UBound(arr)
brr = Application.Transpose(arr)
ReDim Preserve brr(1 To UBound(arr, 2), 1 To m * 2)
brr = Application.Transpose(brr)
For i = 1 To m
brr(m + i, 1) = arr(i, 2): brr(m + i, 2) = arr(i, 1): brr(m + i, 3) = arr(i, 3)
Next i
m = UBound(brr, 1)
qd = Sheet1.Range("a2").Value: zd = Sheet1.Range("b2").Value
If qd <> zd Then Call DG(qd, qd, 0) Else k = 1: jg(k, 1) = 0: jg(k, 2) = qd & "-" & zd
Sheet1.Range("c2").Resize(k, 2).Value = jg()
End '释放全局变量，防止重复点击重复记录
End Sub
Sub DG(dian, lu, jl)
Dim j&, crr(), n&
ReDim crr(1 To m, 1 To 3)
For j = 1 To m '筛选当前点的下一步路径
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)
Next j
For j = 1 To UBound(crr, 1)
If crr(j, 2) = "" Then Exit Sub '某一点遍历完后返回上一点
If InStr(lu, crr(j, 2)) = 0 Then '形成圈时取消连接，否则继续向下连接
lu = lu & "-" & crr(j, 2)
jl = jl + crr(j, 3)
If crr(j, 2) <> zd Then
Call DG(crr(j, 2), lu, jl)
Else '到达终点时记录路径和距离
k = k + 1: jg(k, 2) = lu: jg(k, 1) = jl
End If
lu = Replace(lu, "-" & crr(j, 2), ""): jl = jl - crr(j, 3)'下一点递归调用后未找到路径时（遍历后都形成圈且未达终点），返回本层执行取消连接操作；本层到达终点后取消最后一步连接，继续寻找新的路径
End If
Next j
End Sub

复制代码

ykytom · 发表于 2017-11-20 21:58

上次测试了求树任意结点路径，发现按父结点往根双向收敛比简单按结点所连边穷举搜索效果高多了，这几天琢磨怎样按树的结构来求有回路的图路径，似乎有点眉目。我的思路是，任一选一点为根，先构建一棵树（由N个结点和N－1条边），剩余边做为连枝。将每一连枝与两点在树中路径构成回路做互赋父结点处理。依然换父结点往根双向收敛求任两点路径，只是这次父结点不是唯一的了。在本次汽车寻路中基本实现实找出全部路径，只是如果根点不为要搜索的两点时，因为求路径过程有减枝操作，所遍历的路径有重复的，用字典筛一下就行了。（根如设为要搜索的两点中的任一个都不会有重复，因为这时没有减枝）。刚学不久，代码没有优化。

Option Explicit
Dim DicEdge, DicNode, ArrPath(), r&Sub MyMain()
Dim i&, j&, x$, y$, Arr, NumNode%, b(), s, k, t, d
Set DicEdge = CreateObject("Scripting.Dictionary")
Set DicNode = CreateObject("Scripting.Dictionary")
Set d = CreateObject("Scripting.Dictionary")
[c2:d1000].ClearContents
Arr = Sheets("ÌâÄ¿").[a1].CurrentRegion
For i = 2 To UBound(Arr)
x = Arr(i, 1) & Arr(i, 2): y = Arr(i, 2) & Arr(i, 1)
If DicEdge.exists(x) = False Then DicEdge(x) = Arr(i, 3)
If DicEdge.exists(y) = False Then DicEdge(y) = Arr(i, 3)
If DicNode.exists(Arr(i, 1)) = False Then DicNode(Arr(i, 1)) = ""
If DicNode.exists(Arr(i, 2)) = False Then DicNode(Arr(i, 2)) = ""
Next
NumNode = DicNode.Count: DicNode.RemoveAll: r = 0: ReDim b(1 To UBound(Arr) - NumNode): ReDim ArrPath(1 To 1)
Call CreatSimpleTree(Arr, [b2].Value, NumNode)
For i = NumNode + 1 To UBound(Arr)
r = 0
Call LSearch(Arr(i, 1), Arr(i, 2), "")
b(i - NumNode) = ArrPath(1)
Next
Call CreateComplexTree(b)
r = 0
Call LSearch([a2].Value, [b2].Value, "")
For i = 1 To UBound(ArrPath)
If d.exists(ArrPath(i)) = False Then d(ArrPath(i)) = Array(0, ArrPath(i))
Next
t = d.items
For i = 0 To UBound(t)
s = Split(t(i)(1), "-")
For j = 0 To UBound(s) - 1
t(i)(0) = t(i)(0) + DicEdge(s(j) & s(j + 1))
Next
Next
[c2].Resize(d.Count, 2) = Application.Transpose(Application.Transpose(t))
[c2].Resize(d.Count, 2).Sort ([c2])
Columns("C:D").AutoFit
End SubSub CreatSimpleTree(ByRef a, ByVal RootNode$, ByVal n%)
Dim i%, j%, k%, m%, temp, b()
a(1, 1) = RootNode: a(1, 2) = RootNode: a(1, 3) = 0: DicNode(RootNode) = Array(RootNode)
k = 1: m = 1
Do
For i = m + 1 To UBound(a)
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
m = m + 1
If a(i, 1) = a(k, 1) Then
temp = a(i, 1): a(i, 1) = a(i, 2): a(i, 2) = temp:
End If
If i > m Then
For j = 1 To 3
temp = a(m, j): a(m, j) = a(i, j): a(i, j) = temp
Next
End If
DicNode(a(m, 1)) = Array(a(m, 2))
End If
Next
k = k + 1
Loop Until m >= n
End SubSub LSearch(ByVal node1$, ByVal node2$, ByVal StrL$)
Dim i%, j%, m%, Nstr$, Nnode$, s
If node1 = node2 Then
Nstr = StrL & node2
r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
Else
If DicNode(node1)(0) = node1 Then
Nstr = StrL & node1 & "-"
Call RSearch(node1, node2, Nstr, "")
Else
For i = 0 To UBound(DicNode(node1))
Nnode = DicNode(node1)(i)
If InStr(StrL, Nnode) = 0 Then
Nstr = StrL & node1 & "-"
Call LSearch(Nnode, node2, Nstr)
End If
Next
End If
End If
End SubSub RSearch(ByVal node1$, ByVal node2$, ByVal StrL$, ByVal StrR$)
Dim i%, Nstr$, Nnode$
If node2 = node1 Then
Nstr = StrL & node2 & StrR
r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
Else
For i = 0 To UBound(DicNode(node2))
Nnode = DicNode(node2)(i)
If InStr(StrL, Nnode) = 0 Then
If InStr(StrR, Nnode) = 0 Then
Nstr = "-" & node2 & StrR
Call RSearch(node1, Nnode, StrL, Nstr)
End If
Else
Nstr = Split(Replace(StrL, Nnode, "|"), "|")(0)
Nstr = Nstr & Nnode & "-" & node2 & StrR
r = r + 1: ReDim Preserve ArrPath(1 To r): ArrPath(r) = Nstr
End If
Next
End If
End SubSub CreateComplexTree(ByRef a())
Dim i%, j%, s, b(), m%, n%
For i = 1 To UBound(a)
s = Split(a(i), "-")
For j = 0 To UBound(s)
b = DicNode(s(j))
m = (j + UBound(s)) Mod (UBound(s) + 1)
If Application.IsError(Application.Match(s(m), b, 0)) Then
n = UBound(b) + 1
ReDim Preserve b(n)
b(n) = s(m)
DicNode(s(j)) = b
End If
m = (j + 1) Mod (UBound(s) + 1)
If Application.IsError(Application.Match(s(m), b, 0)) Then
n = UBound(b) + 1
ReDim Preserve b(n)
b(n) = s(m)
DicNode(s(j)) = b
End If
Next
Next
End Sub

复制代码

龙城飞将III · 发表于 2017-11-21 15:15

本帖最后由龙城飞将III 于 2017-11-22 12:04 编辑

Public dicPath As Variant
Sub Path()
t = Timer
Dim strStartNode As String
Dim strEndNode As String
Dim arrPathTemp As Variant
Dim arrPath As Variant
Dim strPath As String
Dim dbDistence As Double
Dim arrResult As Variant
Set dicPath = CreateObject("scripting.dictionary")
strStartNode = Sheet1.Cells(2, "A")
strEndNode = Sheet1.Cells(2, "B")
arrPathTemp = Sheet2.Range("A2:C13")
ReDim arrPath(1 To 2 * UBound(arrPathTemp, 1), 1 To UBound(arrPathTemp, 2))
For i = 1 To 2 * UBound(arrPathTemp, 1)
If i <= UBound(arrPathTemp) Then
arrPath(i, 1) = arrPathTemp(i, 1)
arrPath(i, 2) = arrPathTemp(i, 2)
arrPath(i, 3) = arrPathTemp(i, 3)
Else
arrPath(i, 1) = arrPathTemp(i - UBound(arrPathTemp, 1), 2)
arrPath(i, 2) = arrPathTemp(i - UBound(arrPathTemp, 1), 1)
arrPath(i, 3) = arrPathTemp(i - UBound(arrPathTemp, 1), 3)
End If
Next
For m = 1 To UBound(arrPath)
If arrPath(m, 1) = strStartNode Then
findPath arrPath(m, 1), strEndNode, arrPath, arrPath(m, 1), 0
End If
Next
arrResultpath = dicPath.keys
arrResultDistence = dicPath.items
ReDim arrResult(1 To dicPath.Count, 1 To 2)
For n = 1 To UBound(arrResult)
arrResult(n, 1) = arrResultDistence(n - 1)
arrResult(n, 2) = arrResultpath(n - 1)
Next
With Sheet1
.Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Clear
.Cells(2, "C").Resize(UBound(arrResult), 2) = arrResult
End With
MsgBox "耗时: " & Timer - t & "秒!"
End Sub
Sub findPath(StartNode, EndNode, arrPath, Path, Distence)
For i = 1 To UBound(arrPath)
'开始点是否和要寻找路线的初始点相同
If arrPath(i, 1) = StartNode Then
'是否陷入循环路径
If InStr(Path, arrPath(i, 2)) = 0 Then
Distence_new = Distence + arrPath(i, 3)
Path_new = Path & "-" & arrPath(i, 2)
'结束点是否是终点
If arrPath(i, 2) = EndNode Then
'结果放入字典
dicPath(Path_new) = Distence_new
Exit Sub
End If
'以结束点为初始点继续寻找路径
findPath arrPath(i, 2), EndNode, arrPath, Path_new, Distence_new
End If
End If
Next
End Sub

复制代码

龙城飞将III · 发表于 2017-11-21 15:15

本帖最后由龙城飞将III 于 2017-12-4 19:21 编辑

重新修改：

Public dicPath As Variant
Sub Path()
t = Timer
Dim strStartNode As String
Dim strEndNode As String
Dim arrPathTemp As Variant
Dim arrPath As Variant
Dim strPath As String
Dim dbDistence As Double
Dim arrResult As Variant
Dim rng As Range
Set dicPath = CreateObject("scripting.dictionary")
strStartNode = Sheet1.Cells(2, "A")
strEndNode = Sheet1.Cells(2, "B")
arrPathTemp = Sheet2.Range("A2:C13")
ReDim arrPath(1 To 2 * UBound(arrPathTemp, 1), 1 To UBound(arrPathTemp, 2))
For i = 1 To 2 * UBound(arrPathTemp, 1)
If i <= UBound(arrPathTemp) Then
arrPath(i, 1) = arrPathTemp(i, 1)
arrPath(i, 2) = arrPathTemp(i, 2)
arrPath(i, 3) = arrPathTemp(i, 3)
Else
arrPath(i, 1) = arrPathTemp(i - UBound(arrPathTemp, 1), 2)
arrPath(i, 2) = arrPathTemp(i - UBound(arrPathTemp, 1), 1)
arrPath(i, 3) = arrPathTemp(i - UBound(arrPathTemp, 1), 3)
End If
Next
For m = 1 To UBound(arrPath)
If arrPath(m, 1) = strStartNode Then
findPath arrPath(m, 1), strEndNode, arrPath, arrPath(m, 1), 0
End If
Next
arrResultpath = dicPath.keys
arrResultDistence = dicPath.items
ReDim arrResult(1 To dicPath.Count, 1 To 2)
For n = 1 To UBound(arrResult)
arrResult(n, 1) = arrResultDistence(n - 1)
arrResult(n, 2) = arrResultpath(n - 1)
Next
With Sheet1
.Range(.Cells(2, "C"), .Cells(Rows.Count, "D")).Clear
.Cells(2, "C").Resize(UBound(arrResult), 2) = arrResult
End With
MsgBox "耗时: " & Timer - t & "秒!"
End Sub
Sub findPath(StartNode, EndNode, arrPath, Path, Distence)
For i = 1 To UBound(arrPath)
'开始点是否和要寻找路线的初始点相同
If arrPath(i, 1) = StartNode Then
'是否陷入循环路径
If InStr(Path, arrPath(i, 2)) = 0 Then
Distence_new = Distence + arrPath(i, 3)
Path_new = Path & "-" & arrPath(i, 2)
'结束点是否是终点
If arrPath(i, 2) = EndNode Then
'结果放入字典
dicPath(Path_new) = Distence_new
GoTo next_
End If
'以结束点为初始点继续寻找路径
findPath arrPath(i, 2), EndNode, arrPath, Path_new, Distence_new
End If
End If
next_:
Next
End Sub

复制代码

zopey · 发表于 2017-11-23 10:22

本帖最后由 zopey 于 2017-11-23 10:23 编辑

<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

delete_007 · 发表于 2017-11-24 08:50

Dim sj, jg(), d, N&
Sub delete_007()
Dim i&, stPoint$, endPoint$, m&, T
T = Timer '记录程序运行时间
Set d = CreateObject("scripting.dictionary") '新建字典对象,用于存储各点间的距离
sj = Sheet2.Range("A1").CurrentRegion '取得各点间距离信息
For i = 2 To UBound(sj)
If Not d.exists(sj(i, 1)) Then Set d(sj(i, 1)) = CreateObject("scripting.dictionary")
If Not d.exists(sj(i, 2)) Then Set d(sj(i, 2)) = CreateObject("scripting.dictionary")
d(sj(i, 1))(sj(i, 2)) = sj(i, 3) '将各点信息存入字典,以备后续调用
d(sj(i, 2))(sj(i, 1)) = sj(i, 3)
Next i
With Sheet1
m = .Range("A1").End(xlDown).Row '取得待求解页最后一行行号，可同时计算多个开始、结束点
sj = .Range("A1").Resize(m, 2)
.Range("A1").CurrentRegion.Offset(1, 2).ClearContents '清空已有结果
For i = 2 To m '逐行求解
N = 0 '初始化
Erase jg
stPoint = sj(i, 1) '起始点
endPoint = sj(i, 2) '结束点
If Not d.exists(stPoint) Then
MsgBox "起始点“" & stPoint & "”不存在！"
ElseIf Not d.exists(endPoint) Then
MsgBox "终点“" & endPoint & "”不存在！"
Else
Call digui(stPoint, endPoint, stPoint, 0) '递归求解
.Range("C1").Offset(i - 1, 0).Resize(1, 2 * N) = jg '输出结果
End If
Next i
End With
Set d = Nothing
MsgBox " Time: " & Format(Timer - T, "0.000s") '输出程序运行时间
End Sub
Sub digui(stp, endp, path$, distanse#) '起始点，结束点，路径，距离
Dim j&, key
key = d(stp).keys '取得起始点各个分支节点
For j = 0 To UBound(key) '循环各分支节点
If key(j) = endp Then '当分支节点为终点时输出结果
N = N + 1
ReDim Preserve jg(1 To N * 2)
jg(2 * N) = path & "-" & endp
jg(2 * N - 1) = distanse + d(stp)(endp)
ElseIf InStr("-" & path & "-", "-" & key(j) & "-") = 0 Then '判断分支节点是否已经在前面经过，避免循环往复
Call digui(key(j), endp, path & "-" & key(j), distanse + d(stp)(key(j))) '以该分支节点作为起始点，递归寻求下一个节点
End If
Next j
End Sub

复制代码

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

蓝桥玄霜 · 发表于 2017-11-24 09:44

zopey 发表于 2017-11-23 10:22
Sub gd_serach()

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

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

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

本帖最后由 paciguard 于 2017-11-25 09:44 编辑

Dim dic, St$, Ed$, Str$, Sumdis&, d, cc
Sub lqxs_zd()
Dim ar, jj&
Set dic = CreateObject("Scripting.Dictionary")
Set d = CreateObject("Scripting.Dictionary")
ar = Sheet2.Range("A2:C" & Sheet2.[a65536].End(3).Row)
For i = 1 To UBound(ar)
dic(ar(i, 1) & "," & ar(i, 2)) = ar(i, 3)
dic(ar(i, 2) & "," & ar(i, 1)) = ar(i, 3)
Next i
St = Sheet1.Range("A2")
Ed = Sheet1.Range("B2")
Do While jj <= UBound(dic.keys())
If Split(dic.keys()(jj), ",")(0) = St Then
cc = 0
Do While cc <= UBound(dic.keys())
Str = St & "-" & Split(dic.keys()(jj), ",")(1)
Sumdis = dic(Replace(Str, "-", ","))
Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), cc)
If InStr(Str, St) > 0 And InStr(Str, Ed) > 0 Then
If Not d.exists(Str) Then
d.Add Str, Sumdis
cc = cc + 1
End If
Else
cc = cc + 1
End If
Loop
End If
jj = jj + 1
Loop
Sheet1.Range("C2").Resize(UBound(d.items()) + 1, 1) = Application.Transpose(d.items())
Sheet1.Range("D2").Resize(UBound(d.keys()) + 1, 1) = Application.Transpose(d.keys())
End Sub
Sub Findpath(s, ii)
Dim jjj&
jjj = ii
Dim blog
If jjj >= 23 Then Exit Sub
If InStr(Str, St) > 0 And InStr(Str, Ed) > 0 Then Exit Sub
If Split(dic.keys()(jjj), ",")(0) = s And InStr(Str, Split(dic.keys()(jjj), ",")(1)) = 0 And InStr(Str, Ed) = 0 Then
For Each keya In d
If d.exists(Str & "-" & Split(dic.keys()(jjj), ",")(1) & "-" & Ed) Then
jjj = jjj + 1
Else
Str = Str & "-" & Split(dic.keys()(jjj), ",")(1)
Sumdis = Sumdis + dic(dic.keys()(jjj))
jjj = 0
End If
Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), jjj)
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
Str = Str & "-" & Split(dic.keys()(jjj), ",")(1)
Sumdis = Sumdis + dic(dic.keys()(jjj))
cc = cc + 1
Exit Sub
Else
jjj = jjj + 1
Call Findpath(Split(Str, "-")(UBound(Split(Str, "-"))), jjj)
End If
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

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

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源

点评

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评