特殊排序问题

Albert128

科目余额表,怎么由原始表排序到目标表,不用"编辑自定义列表"方式,想到SQL,
本人不会,望老师赐教!谢谢.(注:目标表内粗体字下要按升序排列)

Albert128

咋木没一位老师肯显身呢!

Albert128

大师们去哪儿啦! 请关注一下此问题.

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, aa, n&, m&
   
3. Dim d, k, t, k1, t1, km$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Sheet1.Activate
   
7. [c3:c500].Clear
   
8. Arr = [a1].CurrentRegion
   
9. For i = 3 To UBound(Arr)
   
10.     km = Left(Arr(i, 1), 4)
    
11.     If Mid(Arr(i, 1), 5, 1) <> "[" Then
    
12.         d(km) = Arr(i, 1)
    
13.     Else
    
14.         d1(km) = d1(km) & i & ","
    
15.     End If
    
16. Next
    
17. k = d.keys: k1 = d1.keys
    
18. t = d1.items: t1 = d.items: n = 2
    
19. For i = 0 To UBound(k)
    
20.     n = n + 1: m = 0
    
21.     [f:f].ClearContents
    
22.     Cells(n, 3) = t1(i)
    
23.     Cells(n, 3).Font.Bold = True
    
24.     If d1.exists(k(i)) Then
    
25.         tt = d1(k(i))
    
26.         tt = Left(tt, Len(tt) - 1)
    
27.         If InStr(tt, ",") Then
    
28.             aa = Split(tt, ",")
    
29.             For j = 0 To UBound(aa)
    
30.                 m = m + 1
    
31.                 Cells(m, 6) = Arr(aa(j), 1)
    
32.             Next
    
33.             [f1].Resize(m, 1).Sort [f1], 1
    
34.             [f1].Resize(m, 1).Copy Cells(n + 1, 3)
    
35.             n = n + m
    
36.         Else
    
37.             n = n + 1
    
38.             Cells(n, 3) = Arr(tt, 1)
    
39.         End If
    
40.     End If
    
41. Next
    
42.     [f:f].ClearContents
    
43. End Sub
    

复制代码

chenzicheng

辅助列排序

蓝桥玄霜

请见附件。点击按钮即可。

Albert128

二位的关注，本人深表感谢！
5楼：巧妙运用了条件格式、text()与counif()两个函数的组合；{:soso_e183:}
6楼蓝版：本人只能望洋兴叹，下来好好参透参透。{:soso_e179:}
（望蓝版若能说明一下，那就最好不过了，让更多的人领悟领悟）

释释然

先做下标记，好好学习。
两位老师的解答都很棒，学生只能望尘莫及。