都来看看这个排序怎么实现，再来看看单位前面的量怎么提取

rzqf

和大家继续研究单位前面的量怎么提取，我用数组公式完成了，，，如果用VBA怎么实现，关键是单位前面没有数值的提取 1。。。

liaozhifa33

excel本身排序达不到这点，我也为这个事情苦恼过，不过我没解决，而是采用了1-001、1-002的方式来解决。坐等大神。

aoe1981

且问：编码最多被“－”分割为几部分？

aman1516

liaozhifa33 发表于 2015-1-2 22:45
excel本身排序达不到这点，我也为这个事情苦恼过，不过我没解决，而是采用了1-001、1-002的方式来解决。坐等 ...

楼主数据有多级，而不是仅仅统一长度与格式就能排序的，且改变源数据一般都有难度。
或许可考虑分列，先分列，排序后再合并还原数据，通过辅助列“曲线救国”的办法试试

liaozhifa33

aman1516 发表于 2015-1-2 23:04
楼主数据有多级，而不是仅仅统一长度与格式就能排序的，且改变源数据一般都有难度。
或许可考虑分列，先 ...

考虑过先分列在和并，但是不清楚元数据中到底有多少分隔符，坐等更好的解决方式。

aoe1981

已经初步解决，代码效率或许不高，可灵活设置编码层数：

1. Option Explicit
   
2. Const cs = 4 '编码层数
   
3. Public Sub PaiXu()
   
4. Dim arr, n&, i&, j&, j1%, k&, k1%, m%, brr, s1, s2, gd, jg, t#
   
5.     t = Timer
   
6.     n = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     If n > 1 Then arr = Range("a1:a" & n).Value Else ReDim arr(1 To 1, 1 To 1): arr(1, 1) = Range("a1").Value
   
8.     jg = arr
   
9.     For i = 1 To n
   
10.         m = (cs - 1) - (Len(arr(i, 1)) - Len(Replace(arr(i, 1), "-", "")))
    
11.         For j = 1 To m
    
12.             arr(i, 1) = arr(i, 1) & "-"
    
13.         Next j
    
14.     Next i
    
15.     For i = 1 To cs
    
16.         For j = 1 To n - 1 '还是老样子，冒泡排序
    
17.             brr = Split(arr(j, 1), "-")
    
18.             For j1 = 1 To i '连接对比量
    
19.                 s1 = s1 & brr(j1 - 1)
    
20.             Next j1
    
21.             For k = j To n
    
22.                 brr = Split(arr(k, 1), "-")
    
23.                 For k1 = 1 To i '连接对比量
    
24.                     s2 = s2 & brr(k1 - 1)
    
25.                 Next k1
    
26.                 If s1 > s2 Then gd = jg(j, 1): jg(j, 1) = jg(k, 1): jg(k, 1) = gd
    
27.                 s2 = ""
    
28.             Next k
    
29.             s1 = ""
    
30.         Next j
    
31.     Next i
    
32.     Range("c:c").ClearContents: Range("c1").Resize(n) = jg: Range("d1") = "用时：" & Format(Timer - t, "0.0000") & "秒。"
    
33. End Sub
    
34. string
    

复制代码

aoe1981

效果图如下：


附件如下：
号导入（aoe1981）.rar (18.25 KB, 下载次数: 51)

2015-1-3 00:28 上传

点击文件名下载附件

（8楼问题已更新。）
推荐下载19楼附件，包含两种排序思路。

aoe1981

不好意思，有个BUG，测试5层时发现的，现在已修复：

1. Option Explicit
   
2. Const cs = 5 '编码层数
   
3. Public Sub PaiXu()
   
4. Dim arr, n&, i&, j&, j1%, k&, k1%, m%, brr, s1, s2, gd, jg, t#
   
5.     t = Timer
   
6.     n = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     If n > 1 Then arr = Range("a1:a" & n).Value Else ReDim arr(1 To 1, 1 To 1): arr(1, 1) = Range("a1").Value
   
8.     jg = arr
   
9.     For i = 1 To n
   
10.         m = (cs - 1) - (Len(arr(i, 1)) - Len(Replace(arr(i, 1), "-", "")))
    
11.         For j = 1 To m
    
12.             arr(i, 1) = arr(i, 1) & "-"
    
13.         Next j
    
14.     Next i
    
15.     For i = 1 To cs
    
16.         For j = 1 To n - 1 '还是老样子，冒泡排序
    
17.             brr = Split(arr(j, 1), "-")
    
18.             For j1 = 1 To i '连接对比量
    
19.                 s1 = s1 & brr(j1 - 1)
    
20.             Next j1
    
21.             For k = j + 1 To n
    
22.                 brr = Split(arr(k, 1), "-")
    
23.                 For k1 = 1 To i '连接对比量
    
24.                     s2 = s2 & brr(k1 - 1)
    
25.                 Next k1
    
26.                 If s1 > s2 Then
    
27.                     gd = jg(j, 1): jg(j, 1) = jg(k, 1): jg(k, 1) = gd
    
28.                     gd = arr(j, 1): arr(j, 1) = arr(k, 1): arr(k, 1) = gd
    
29.                 End If
    
30.                 s2 = ""
    
31.             Next k
    
32.             s1 = ""
    
33.         Next j
    
34.     Next i
    
35.     Range("c:c").ClearContents: Range("c1").Resize(n) = jg: Range("d1") = "用时：" & Format(Timer - t, "0.0000") & "秒。"
    
36. End Sub
    

复制代码

前楼附件会同步更新。

aoe1981

现在5层效果如下：

aoe1981

根据以下指点：
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1176846&pid=8024014

简化为：

1. Option Explicit
   
2. Const cs = 5 '编码层数
   
3. Public Sub PaiXu()
   
4. Dim arr, n&, i&, j&, j1%, k&, k1%, m%, brr, s1, s2, gd, jg, t#
   
5.     t = Timer
   
6.     n = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     If n > 1 Then arr = Range("a1:a" & n).Value Else ReDim arr(1 To 1, 1 To 1): arr(1, 1) = Range("a1").Value
   
8.     jg = arr
   
9.     For i = 1 To n
   
10.         m = (cs - 1) - (Len(arr(i, 1)) - Len(Replace(arr(i, 1), "-", "")))
    
11.         arr(i, 1) = arr(i, 1) & String(m, "-")
    
12.     Next i
    
13.     For i = 1 To cs
    
14.         For j = 1 To n - 1 '还是老样子，冒泡排序
    
15.             brr = Split(arr(j, 1), "-")
    
16.             For j1 = 1 To i '连接对比量
    
17.                 s1 = s1 & brr(j1 - 1)
    
18.             Next j1
    
19.             For k = j + 1 To n
    
20.                 brr = Split(arr(k, 1), "-")
    
21.                 For k1 = 1 To i '连接对比量
    
22.                     s2 = s2 & brr(k1 - 1)
    
23.                 Next k1
    
24.                 If s1 > s2 Then
    
25.                     gd = jg(j, 1): jg(j, 1) = jg(k, 1): jg(k, 1) = gd
    
26.                     gd = arr(j, 1): arr(j, 1) = arr(k, 1): arr(k, 1) = gd
    
27.                 End If
    
28.                 s2 = ""
    
29.             Next k
    
30.             s1 = ""
    
31.         Next j
    
32.     Next i
    
33.     Range("c:c").ClearContents: Range("c1").Resize(n) = jg: Range("d1") = "用时：" & Format(Timer - t, "0.0000") & "秒。"
    
34. End Sub
    

复制代码