三级明细的科目余额表，如何让末级科目加上一级、二级科目的名称？

sakurap10

求助各位大神，如图，比如想让小明变成应收账款-行政部-小明。该如何实现？提前感谢！

loirol

一级编号一定4位？

loirol

以下代码以一级序号均为4位数为前提，供参考

sakurap10

loirol 发表于 2021-8-25 10:54
一级编号一定4位？

是的没错，一般用友导出的科目余额表容易出现这种问题。用友的设置一级编号都是4位

loirol

sakurap10 发表于 2021-8-25 11:08
是的没错，一般用友导出的科目余额表容易出现这种问题。用友的设置一级编号都是4位

看楼上。。。。

sakurap10

loirol 发表于 2021-8-25 11:14
看楼上。。。。

感谢您，因为我的回复需要审核。您的回复很实用！

zpy2

select *,(select group_concat(科目名称,'-') from 科目编码名称明细表 b where a.科目编码 like b.科目编码||'%') 科目全称 from 科目编码名称明细表 a

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Len(arr(i, 1)) = 4 Then
    
11.         arr(i, 3) = arr(i, 2)
    
12.         d(CStr(arr(i, 1))) = arr(i, 2)
    
13.       Else
    
14.         xm = Left(arr(i, 1), Len(arr(i, 1)) - IIf(Len(arr(i, 1)) = 7, 3, 2))
    
15.         If d.exists(xm) Then
    
16.           arr(i, 3) = d(xm) & "-" & arr(i, 2)
    
17.           d(CStr(arr(i, 1))) = arr(i, 3)
    
18.         End If
    
19.       End If
    
20.     Next
    
21.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
22.   End With
    
23. End Sub
    

复制代码

chxw68

详见附件。

chxw68

提供一个不用字典的。

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a2:c" & r)
   
7.     For i = 1 To UBound(arr)
   
8.       If Len(arr(i, 1)) = 4 Then
   
9.         arr(i, 3) = arr(i, 2)
   
10.       End If
    
11.       For j = i + 1 To UBound(arr)
    
12.         If Not arr(j, 1) Like arr(i, 1) & "*" Then
    
13.           Exit For
    
14.         End If
    
15.         If arr(j, 1) Like arr(i, 1) & "??" Or arr(j, 1) Like arr(i, 1) & "???" Then
    
16.           arr(j, 3) = arr(i, 3) & "-" & arr(j, 2)
    
17.         End If
    
18.       Next
    
19.     Next
    
20.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
21.   End With
    
22. End Sub
    
23. 
    

复制代码