怎么让排序更直观，不让10排在1和2之间?

水和米

如图，排序后，十位数的项目会自动排在1和2之间


道理我都懂，原因是文本排序中，十位数首字符1是小于2的，所以就排在前面
解决的其中办法之一是将项目1，2，……，改成项目01，02……
但一是，大多数时候是现实应用中不允许，二是家园里的大神藏龙卧虎，
希望大神能为小弟指点迷津，感谢不尽，这对我很重要~~~

moonlit123

你把A列拆成 汉字+数字 两列，
然后按数字列 排序 不就行了么？

排完再合并再把汉字和数字合并回去不就没事了？

如果项目少的话，可以自定义序列...

dj5121766

单元格输入数字，自定义单元格格式前面加上“”项目“”2个字

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j
  arr = [a1].CurrentRegion.Resize(, 2)
  For i = 1 To UBound(arr, 1)
    For j = 1 To Len(arr(i, 1))
      If IsNumeric(Mid(arr(i, 1), j, 1)) Then
        arr(i, 2) = left(arr(i, 1), j - 1) & Format(Mid(arr(i, 1), j), "000000")
        Exit For
      End If
    Next
    If j = Len(arr(i, 1)) + 1 Then arr(i, 2) = arr(i, 2)
  Next
  Call qsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 2)
  [d1].Resize(UBound(arr, 1)) = arr
End Sub

Sub qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x As String, t As String
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Sub

liuxi001

1. Option Explicit
   
2. Sub mysort()
   
3.     Dim ar, re, x%, mh, s
   
4.     Set re = CreateObject("vbscript.regexp")
   
5.     ar = [a1].CurrentRegion.Resize(, [a1].CurrentRegion.Columns.Count + 1)
   
6.     re.Pattern = "\D+"
   
7.     For x = 2 To UBound(ar)
   
8.         s = re.Replace(ar(x, 1), "")
   
9.         ar(x, UBound(ar, 2)) = Replace(ar(x, 1), s, "") & Format(s, "00")
   
10.     Next
    
11.     Call ShellSort(ar, , , 2)
    
12.     [e1].Resize(UBound(ar), UBound(ar, 2) - 1) = ar
    
13. End Sub
    
14. Function ShellSort(Arr, Optional Factor = 0, Optional Mode = 0, Optional First = 1, Optional Last = 0)
    
15. 'shellsort(数组，条件(默认最后一列)，模式0升序1降序(默认0升序)，开始行号，最后行号)
    
16.     Dim Totalsize, interval, x, y, o
    
17.     If Factor = 0 Then Factor = UBound(Arr, 2)
    
18.     If Last = 0 Then Last = UBound(Arr)
    
19.     ReDim temp(1 To UBound(Arr, 2)): Totalsize = Last - First + 1: interval = 1
    
20.     If Totalsize > 13 Then
    
21.         Do While interval < Totalsize: interval = interval * 3 + 1: Loop
    
22.         interval = interval \ 9
    
23.     End If
    
24.     Do While interval
    
25.         For x = First + interval To Last
    
26.             For o = 1 To UBound(Arr, 2): temp(o) = Arr(x, o): Next
    
27.             For y = x - interval To First Step -interval
    
28.                 If Mode = 1 Then
    
29.                     If Arr(y, Factor) > temp(Factor) Then Exit For
    
30.                 ElseIf Mode = 0 Then
    
31.                     If Arr(y, Factor) <= temp(Factor) Then Exit For
    
32.                 End If
    
33.                 For o = 1 To UBound(Arr, 2): Arr(y + interval, o) = Arr(y, o): Next
    
34.             Next y
    
35.             For o = 1 To UBound(Arr, 2): Arr(y + interval, o) = temp(o): Next
    
36.         Next x
    
37.         interval = interval \ 3
    
38.     Loop
    
39. End Function
    

复制代码

hcm19522

D2:D13{=INDEX(A:A,RIGHT(SMALL(SUBSTITUTE(A$2:A$13,"项目","0.")*10^8+ROW($2:$13),ROW(A1)),6))

方式二{=INDEX(A:A,RIGHT(SMALL(LEFT(MID(A$2:A$13,3,9)&0,2)*10^8+ROW($2:$13),ROW(A1)),6))

yaozong

1. Sub test()
   
2.   Dim arr, i&, j&, x&, y&, r&, s
   
3.   arr = [a1].CurrentRegion.Value
   
4.   r = UBound(arr)
   
5.   For i = 1 To r - 1
   
6.     For j = i + 1 To r
   
7.       x = Val(Trim(Mid(arr(i, 1), 3)))
   
8.       y = Val(Trim(Mid(arr(j, 1), 3)))
   
9.       If x > y Then
   
10.         s = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = s
    
11.       End If
    
12.     Next
    
13.   Next
    
14.   [c1].CurrentRegion.ClearContents
    
15.   [c1].Resize(r) = arr
    
16. End Sub

复制代码

yaozong

参考附件