会计科目有个分级，只取最末级数据

moyan_o

A列为会计科目代码，存在多级科目，只取最末级科目，遇到末级科目有核算项目的（如C列），填充对应的末级科目及科目名称（A列和B列），效果见工作表（实现效果），非常感谢各位大佬！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim flg As Boolean
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
   
7.     arr = .Range("a2:e" & r)
   
8.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
9.     For i = 2 To UBound(arr)
   
10.       If Len(arr(i, 1)) = 0 Then
    
11.         arr(i, 1) = arr(i - 1, 1)
    
12.       End If
    
13.       If Len(arr(i, 2)) = 0 Then
    
14.         arr(i, 2) = arr(i - 1, 2)
    
15.       End If
    
16.     Next
    
17.     For i = 1 To UBound(arr) - 1
    
18.       If Len(arr(i, 3)) <> 0 Then
    
19.         flg = True
    
20.         For k = i + 1 To UBound(arr)
    
21.           If arr(k, 1) Like arr(i, 1) & ".*" Then
    
22.             flg = False
    
23.             Exit For
    
24.           End If
    
25.         Next
    
26.         If flg Then
    
27.           m = m + 1
    
28.           For j = 1 To UBound(arr, 2)
    
29.             brr(m, j) = arr(i, j)
    
30.           Next
    
31.         End If
    
32.       End If
    
33.     Next
    
34.     m = m + 1
    
35.     For j = 1 To UBound(arr, 2)
    
36.       brr(m, j) = arr(i, j)
    
37.     Next
    
38.   End With
    
39.   With Worksheets("实现效果")
    
40.     .UsedRange.Offset(1, 0).ClearContents
    
41.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
42.   End With
    
43.    
    
44. End Sub
    

复制代码

chxw68

详见附件。

一指禅62

方法多样

http://club.excelhome.net/forum. ... p;extra=#pid8627317

http://club.excelhome.net/thread-1086559-1-1.html

moyan_o

chxw68 发表于 2020-7-10 08:18
详见附件。

您好，案例中末级科目如1001.01 库存现金_人民币 没显示出来，只显示了有核算项目的末级科目，非常感谢！！！

moyan_o

chxw68 发表于 2020-7-10 08:18
详见附件。

您好，像1001.01库存现金_人民币这样子的末级科目并没有留下来，只留下有核算项目的末级科目，非常感谢！！

moyan_o

感谢楼上各位大佬的帮助！！！

moyan_o

2楼大佬的方案里的1001.01 库存现金_人民币 这样的末级科目没有显示出来，只显示了有核算项目的末级科目。

deadzlq

PowerQuery参考解法

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, m
  With Sheets("sheet1")
    arr = .Range("a2:e" & .Cells(Rows.Count, "c").End(xlUp).Row + 1).Value
    For i = 2 To UBound(arr, 1) - 1
      If Len(arr(i, 1)) > Len(arr(i - 1, 1)) And Len(arr(i, 1)) > Len(arr(i + 1, 1)) Then
        If Len(arr(i + 1, 1)) = 0 Then
          For j = i + 1 To UBound(arr, 1) - 1
            m = m + 1
            arr(m, 1) = arr(i, 1): arr(m, 2) = arr(i, 2)
            For k = 3 To UBound(arr, 2)
              arr(m, k) = arr(j, k)
            Next
            If Len(arr(j + 1, 1)) > 0 Or j = UBound(arr, 1) - 1 Then i = j: Exit For
          Next
        Else
          m = m + 1
          For j = 1 To UBound(arr, 2)
            arr(m, j) = arr(i, j)
          Next
        End If
      End If
    Next
  End With
  Sheets("实现效果").[a2].Resize(m, UBound(arr, 2)) = arr
End Sub