排序问题

czr0373

不知道怎么描述，先按左边的字母升序，然后按中间的数字升序，最后按右边的数字升序

yjh_27

左边的字母是国定2位，中间的字母是P这样的规律吗？

czr0373

yjh_27 发表于 2013-11-25 10:44
左边的字母是国定2位，中间的字母是P这样的规律吗？

是的，并且中间的数字只有2-3位数。。。

yjh_27

参见附件。

czr0373

yjh_27 发表于 2013-11-25 11:27
参见附件。

非常感谢，非常非常感谢！！！太了不起了！！！！

Zamyi

yjh_27 发表于 2013-11-25 11:27
参见附件。

二维数组排序的精髓只是对其记录的位置进行排序，排序过程中原数组都没有动，可以称之为“虚拟排序”吧。从一列拆分为三列进行排序，再由三列合并为一列，有点绕。

1. Sub test()
   
2. Dim a(), w() As Long
   
3. r = Range("a2", [a65536].End(3))
   
4. ReDim a(1 To UBound(r), 1 To 3)
   
5. With CreateObject("VBSCRIPT.REGEXP")
   
6.   .Pattern = "(\D+)(\d+)(\D+)(\d+)"
   
7.   For i = 1 To UBound(r)
   
8.     t = Split(.Replace(r(i, 1), "$1 $2 $4"))
   
9.     a(i, 1) = t(0)
   
10.     a(i, 2) = Val(t(1))
    
11.     a(i, 3) = Val(t(2))
    
12.   Next
    
13. End With
    
14. ZSort a, w, 1, 0, 2, 0, 3
    
15. ReDim a(1 To UBound(r), 1 To 1)
    
16. For i = 1 To UBound(r)
    
17.   a(i, 1) = r(w(i), 1)
    
18. Next
    
19. [c2].Resize(UBound(r)) = a
    
20. End Sub
    
21. Public Sub ZSort(Olda(), w() As Long, ParamArray c())
    
22. 'Olda()：为排序数组
    
23. 'Newa()：为存放位置数组
    
24. 'ParamArray c():传递排序参数数组,奇数个为排序列号，偶数为升降序，0或者省略为升序
    
25. Dim P() As Long, B() As Boolean
    
26. Dim i&, j&, k&, n1&, n2&, nb&, ne&
    
27. k = UBound(c)
    
28. If k = -1 Then
    
29.   ReDim P(1)
    
30.   P(0) = 1
    
31. Else
    
32.   If k Mod 2 Then ReDim P(k) Else ReDim P(k + 1)
    
33.   For i = 0 To k
    
34.     P(i) = c(i)
    
35.   Next
    
36. End If
    
37. n1 = LBound(Olda)
    
38. n2 = UBound(Olda)
    
39. ReDim w(n1 To n2)
    
40. ReDim B(n1 To n2)
    
41. For i = n1 To n2
    
42.   w(i) = i
    
43. Next
    
44. If P(1) = 0 Then QSort Olda, w, P(0), n1, n2 Else QSort2 Olda, w, P(0), n1, n2
    
45. For i = 2 To k Step 2
    
46.   nb = n1
    
47.   ne = n1
    
48.   While ne < n2
    
49.     Do
    
50.       ne = ne + 1
    
51.       If ne > n2 Then Exit Do
    
52.     Loop Until B(ne) Or Olda(w(ne), P(i - 2)) <> Olda(w(ne - 1), P(i - 2))
    
53.     If ne - nb > 1 Then
    
54.       If P(i + 1) = 0 Then QSort Olda, w, P(i), nb, ne - 1 Else QSort2 Olda, w, P(i), nb, ne - 1
    
55.     End If
    
56.     If ne <= n2 Then B(ne) = True
    
57.     nb = ne
    
58.   Wend
    
59. Next
    
60. End Sub
    
61. 
    
62. Private Sub QSort(r(), w() As Long, Key&, L&, H&)
    
63. Dim i&, j&, x, y
    
64. i = L
    
65. j = H
    
66. x = r(w(L + 1 + Int((H - L - 1) * Rnd)), Key)
    
67. While (i <= j)
    
68.   While (r(w(i), Key) < x And i < H)
    
69.     i = i + 1
    
70.   Wend
    
71.   While (x < r(w(j), Key) And j > L)
    
72.     j = j - 1
    
73.   Wend
    
74.   If (i <= j) Then
    
75.     y = w(i)
    
76.     w(i) = w(j)
    
77.     w(j) = y
    
78.     i = i + 1
    
79.     j = j - 1
    
80.   End If
    
81. Wend
    
82. If (L < j) Then QSort r, w, Key, L, j
    
83. If (i < H) Then QSort r, w, Key, i, H
    
84. End Sub
    
85. 
    
86. Private Sub QSort2(r(), w() As Long, Key&, L&, H&)
    
87. Dim i&, j&, x, y
    
88. i = L
    
89. j = H
    
90. x = r(w(L + 1 + Int((H - L - 1) * Rnd)), Key)
    
91. While (i <= j)
    
92.   While (r(w(i), Key) > x And i < H)
    
93.     i = i + 1
    
94.   Wend
    
95.   While (x > r(w(j), Key) And j > L)
    
96.     j = j - 1
    
97.   Wend
    
98.   If (i <= j) Then
    
99.     y = w(i)
    
100.     w(i) = w(j)
     
101.     w(j) = y
     
102.     i = i + 1
     
103.     j = j - 1
     
104.   End If
     
105. Wend
     
106. If (L < j) Then QSort2 r, w, Key, L, j
     
107. If (i < H) Then QSort2 r, w, Key, i, H
     
108. End Sub

复制代码

alzeng

以下代码须使用ActiveScriptRuby，下载： http://www.artonx.org/data/asr/ActiveRuby.msi

1. Sub nSort()
   
2.     Dim Arr, k%, oJs As Object
   
3. 
   
4.     Set oJs = CreateObject("ScriptControl"): oJs.Language = "RubyScript"
   
5.     Arr = [A1].CurrentRegion: oJs.eval ("h={};")
   
6.     For k = 2 To UBound(Arr)
   
7.         oJs.eval ("s='" & Arr(k, 1) & "';a=s.gsub(/(\d+)/,'-\1-').scan" _
   
8.                   & "(/\w+/);a[1],a[3]='%05d'%a[1],'%05d'%a[3];h[a*'']=s;")
   
9.     Next
   
10.     Arr = oJs.eval("a=[];h.keys.sort.each{|o|a<<[h[o]]};a;")
    
11.     [D2].Resize(k - 2) = Arr: Set oJs = Nothing
    
12. End Sub

复制代码

yjh_27

Zamyi 发表于 2013-11-26 10:42
二维数组排序的精髓只是对其记录的位置进行排序，排序过程中原数组都没有动，可以称之为“虚拟排序”吧。 ...

正则很强，还要学习。

代码是向你学的，还没完全理解。

czr0373

Zamyi 发表于 2013-11-26 10:42
二维数组排序的精髓只是对其记录的位置进行排序，排序过程中原数组都没有动，可以称之为“虚拟排序”吧。 ...

高人，顶级高人，非常感谢！！！！

czr0373

Zamyi 发表于 2013-11-26 10:42
二维数组排序的精髓只是对其记录的位置进行排序，排序过程中原数组都没有动，可以称之为“虚拟排序”吧。 ...

真好，，不过如果中间不是P，而是其它符号，比如-
类似于HH3-3，ZD32-21，NB44-32，
并且和带P的混在一起排序怎么搞？？
非常感谢！！！