没有算法和数据结构基础，完成这个题目还是很难，同时考虑到效能问题

hai167 · 发表于 2015-5-23 17:06

本帖最后由 hai167 于 2015-5-23 17:07 编辑

没有算法和数据结构基础，完成这个题目还是很难，同时考虑到效能问题，求助一下高手，非常感谢。

test.rar (16.15 KB, 下载次数: 42)

yjh_27 · 发表于 2015-5-23 17:45

先按BOM整理

其他再说

liulang0808 · 发表于 2015-5-23 18:21

Sub 按钮1_Click()
Application.ScreenUpdating = False
Dim brr()
Set d = CreateObject("scripting.dictionary")
arr = [a3:a22]
For j = 1 To UBound(arr)
      d(Split(arr(j, 1), "-")(1)) = ""
Next j
a = 0
For j = 1 To UBound(arr)
      If Not d.exists(Split(arr(j, 1), "-")(0)) Then
         a = a + 1
         ReDim Preserve brr(1 To 2, 1 To a)
         brr(1, a) = Split(arr(j, 1), "-")(0)
      End If
Next j
a = 3
For j = 1 To UBound(brr, 2)
l1:
      If brr(1, j) <> "A" Then
         For i = 1 To UBound(arr)
            If Left(arr(i, 1), 1) = brr(1, j) Then
                  brr(2, j) = brr(2, j) & "," & arr(i, 1)
                  brr(1, j) = Right(arr(i, 1), 1)
                  If brr(1, j) <> "A" Then
                     str1 = Mid(brr(2, j), 2)
                     str2 = ""
                     If InStr(str1, ",") > 0 Then
                        crr = Split(str1, ",")
                        For k = UBound(crr) To 0 Step -1
                              str2 = str2 & "," & Right(crr(k), 1) & "-" & Left(crr(k), 1)
                        Next k
                        str2 = Mid(str2, 2)
                     Else
                        str2 = Right(str1, 1) & "-" & Left(str1, 1)
                     End If
                        Cells(a, 5) = str2
                        Cells(a, 3) = Mid(brr(2, j), 2)
                     a = a + 1
                  End If
            End If
         Next i
         GoTo l1
      End If
Next j
Application.ScreenUpdating = True
End Sub

liulang0808 · 发表于 2015-5-23 18:22

看看是否满足需求吧
3，4列结果

lipton · 发表于 2015-5-23 18:41

也可以用XML树

<A Childnode='3'>
<B Childnode='1'>
<E Childnode='2'>
<J Childnode='1'>
<R Childnode='1'>
</R>
</J>
<K Childnode='0'>
</K>
</E>
</B>
</A>

复制代码

E节点的例子：
E 有两个子节点 J与K J有子节点，K无子节点，停止递归返回K节点

hai167 · 发表于 2015-5-23 19:51

lipton 发表于 2015-5-23 18:41
也可以用XML树

一直不知道XML怎么处理树，能不能来个完整一点的代码，谢谢。

liulang0808 · 发表于 2015-5-23 19:57

罗列出了所有的结果，从其中选择最短的，再处理下就好了，很容易的，只要左侧第一个字母一样，单元格内数字最少的就是最短路径

hai167 · 发表于 2015-5-23 21:57

yjh_27 发表于 2015-5-23 17:45
先按BOM整理

其他再说

然后呢？谢谢

Vicel · 发表于 2015-5-24 00:09

hai167 发表于 2015-5-23 21:57
然后呢？谢谢

然后结果出来了，请测试

Sub test() 'By Vicel
Dim ar, br, cr(), d As Object, t$, temp, i&, j&, n&
Set d = CreateObject("scripting.dictionary")
ar = Range("A3:A" & [A65536].End(xlUp).Row)
ReDim Preserve ar(1 To UBound(ar), 1 To 3)
For i = 1 To UBound(ar)
br = Split(ar(i, 1), "-")
ar(i, 2) = br(0): ar(i, 3) = br(1)
t = t & "," & br(1)
d(br(0)) = ar(i, 1)
Next i
ReDim cr(1 To UBound(ar))
For i = 1 To UBound(ar)
If InStr(t, ar(i, 2)) = 0 Then
n = n + 1
temp = ar(i, 3)
Do While d.exists(temp)
d(ar(i, 2)) = d(ar(i, 2)) & "," & d(temp)
temp = Split(d(temp), "-")(1)
Loop
cr(n) = d(ar(i, 2))
End If
Next i
For i = 1 To UBound(ar)
br = Filter(cr, ar(i, 1))
temp = br(0)
If UBound(br) > 0 Then
For j = 1 To UBound(br)
If Len(br(j)) < Len(temp) Then temp = br(j)
Next j
End If
If InStr(temp, ar(i, 1)) = 1 Then
ar(i, 2) = ""
Else
ar(i, 2) = StrReverse(Left(temp, InStr(temp, ar(i, 1)) - 2))
End If
Next i
[B3].Resize(UBound(ar), 1) = Application.Index(ar, , 2)
Set d = Nothing
End Sub

复制代码

子节点到末端最短路径.zip (51.63 KB, 下载次数: 37)

yjh_27 · 发表于 2015-5-24 11:28

1加参数，控制起点。2加参数,添加索引，用于找最短路径

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

[求助] 没有算法和数据结构基础，完成这个题目还是很难，同时考虑到效能问题

评分

评分

评分