树形结构分级求和vba如何实现？

laisme888

如图所示，这个用vba怎么实现呢？
有一种思路说是用字典。。。求示范
（任何树状结构，都可以变成两列的一维表：一列是节点，一列是父节点；循环整个列表，碰到每个节点，就加入字典，item置为0。如果找不到.号，就不操作，如果找到.号，就取被循环到的节点名称最后一个点号之前的部分，给对应字典item值加1）

microyip

以分隔符分开后，建立字典求和即可

laisme888

microyip 发表于 2020-3-14 13:23
以分隔符分开后，建立字典求和即可

求代码

yjh_27

BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html
(出处: ExcelHome技术论坛)

一把小刀闯天下

'数据太少，供参考，，，

Option Explicit

Sub test()
  Dim arr, brr(20), i, j, p, t
  arr = Range("a2:b" & [a2].End(xlDown).Row)
  For i = UBound(arr, 1) To 1 Step -1
    t = Split(arr(i, 1), ".")
    If p = 0 Then
      p = UBound(t): brr(p) = arr(i, 2)
      brr(0) = brr(0) + arr(i, 2)
    Else
      If UBound(t) = p Then
        brr(p) = brr(p) + arr(i, 2)
        brr(0) = brr(0) + arr(i, 2)
      Else
        If UBound(t) < p Then
          arr(i, 2) = brr(p)
          If UBound(t) > 0 Then brr(UBound(t)) = brr(p)
        Else
          brr(UBound(t)) = arr(i, 2)
          brr(0) = brr(0) + arr(i, 2)
        End If
        p = UBound(t)
      End If
    End If
    If UBound(t) = 0 Then arr(i, 2) = brr(0): brr(0) = 0: p = 0
  Next
  [e2].Resize(UBound(arr, 1), 2) = arr
End Sub

laisme888

一把小刀闯天下 发表于 2020-3-14 17:14
'数据太少，供参考，，，

Option Explicit

谢谢，大神能用字典解决吗？我一直好奇字典方法怎么解决

一把小刀闯天下

laisme888 发表于 2020-3-14 18:43
谢谢，大神能用字典解决吗？我一直好奇字典方法怎么解决

会用字典，但字典用在你这还真不会。看看有没有字典大神路过的，，，

northwolves

1. Sub test()
   
2.     Dim dic As Object, arr, t As String, i&
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         t = "'" & arr(i, 1)
   
7.         While InStr(t, ".")
   
8.             dic(t) = dic(t) + arr(i, 2)
   
9.             t = Left(t, InStrRev(t, ".") - 1)
   
10.         Wend
    
11.         dic(t) = dic(t) + arr(i, 2)
    
12.     Next
    
13.     With [d2].Resize(dic.Count, 2)
    
14.         .Value = WorksheetFunction.Transpose(Array(dic.keys, dic.items))
    
15.         .Sort [d2]
    
16.     End With
    
17. End Sub
    
18. 
    

复制代码

yachtz

用辅助列+公式。负数会导致错误结果 工作簿1.rar (10.96 KB, 下载次数: 6)

2020-3-14 19:57 上传

点击文件名下载附件

不知道为什么

1. Sub test()
   
2.     Dim arr, brr()
   
3.     arr = [a1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 2)
   
5.     For i = 2 To UBound(arr)
   
6.         ms = Split(arr(i, 1), "."): t = UBound(ms)
   
7.         brr(i, 1) = arr(i, 1): brr(i, 2) = arr(i, 2)
   
8.         For j = 2 To UBound(arr)
   
9.             If j <> i And UBound(Split(arr(j, 1), ".")) >= t Then
   
10.                 For h = 0 To t
    
11.                     s = s & "." & Split(arr(j, 1), ".")(h)
    
12.                 Next h
    
13.                 s = Mid(s, 2)
    
14.                 If s = arr(i, 1) Then brr(i, 2) = brr(i, 2) + arr(j, 2)
    
15.                 s = ""
    
16.             End If
    
17.         Next j
    
18.     Next i
    
19.     [d1].Resize(UBound(arr), 2) = brr
    
20. End Sub

复制代码