有文本数字混合排列

ba3259878266

有文本数字混合排列 谢谢老师帮忙

yylucke

请参见附件

yylucke

Private Sub CommandButton1_Click()
Sheet1.Columns(3).ClearContents
MyLatRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
If MyLatRow = 1 Then GoTo Line100

MyArr = Sheet1.Range("A1:A" & MyLatRow)
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To MyLatRow
    Dic(InStr(MyArr(i, 1), "X")) = Dic(InStr(MyArr(i, 1), "X")) + MyArr(i, 1) & "│"
Next i

For i = 1 To Dic.Count
    kk = Dic(Application.Small(Dic.keys, i))
    kk = Left(kk, Len(kk) - 1) '这个数组最后一个是空值，要剔除
    kk = Split(kk, "│")
    hh = Application.Transpose(MySort(kk))
    MyLatRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
    Sheet1.Cells(MyLatRow, 3).Resize(UBound(hh), 1) = hh
Next

Exit Sub
Line100:
    Sheet1.Cells(1, 1) = Sheet1.Cells(1, 1)
End Sub

Function MySort(MyArr)
M = 0
For i = 0 To UBound(MyArr) - 1
If MyArr(i) <= MyArr(i + 1) Then
  If i > M Then
   M = i
  Else
   i = M
  End If
  GoTo kk:
Else
x = MyArr(i)
MyArr(i) = MyArr(i + 1)
MyArr(i + 1) = x
If i <> 1 Then i = i - 2
End If
kk:
Next i
MySort = MyArr
End Function

ba3259878266

yylucke 发表于 2018-6-4 10:00
Private Sub CommandButton1_Click()
Sheet1.Columns(3).ClearContents
MyLatRow = Sheet1.Cells(Rows.Co ...

能不能在附件里面设置一下  麻烦了

ba3259878266

yylucke 发表于 2018-6-4 09:58
请参见附件

附件打不开

yylucke

ba3259878266 发表于 2018-6-4 10:39
附件打不开

附件是压缩文件，解压就OK了

grf1973

1. Sub mysort()
   
2.     arr = Range("a1:a" & [a65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr))
   
4.     For i = 1 To UBound(arr)
   
5.         x = arr(i, 1)
   
6.         brr(i) = InStr(x, "X") * 1000 + Val(Replace(x, "X", ""))    '给每个字符一个特定的权重值（X的位置*1000+剩下数字的大小）
   
7.     Next
   
8.     For i = 1 To UBound(brr) - 1  '根据权重值同步排序
   
9.         For j = i + 1 To UBound(brr)
   
10.             If brr(j) < brr(i) Then
    
11.                 tmp = brr(j): brr(j) = brr(i): brr(i) = tmp
    
12.                 tmp = arr(j, 1): arr(j, 1) = arr(i, 1): arr(i, 1) = tmp
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     [d1].Resize(UBound(arr)) = arr
    
17. End Sub
    

复制代码

lrh788

grf1973 发表于 2018-6-4 10:57

请教下，你这种把代码加序号是怎么做到的

ba3259878266

grf1973 发表于 2018-6-4 10:57

谢谢老师 很好用

lsdongjh

增加辅助列的简易方法，缺点是要有一个辅助列

1. Option Explicit
   
2. 
   
3. Sub mySort()
   
4.     Dim SH As Worksheet
   
5.     Dim rgSource As Range, rgKey1 As Range, rgKey2 As Range
   
6.     Dim arr As Variant, lngRow As Long
   
7.    
   
8.     Set SH = Sheets("Sheet1")
   
9.     lngRow = SH.Range("A" & Rows.Count).End(xlUp).Row
   
10.     arr = SH.Range("A1:B" & lngRow)
    
11.     Set rgSource = SH.Range("A1:B" & lngRow)
    
12.     Set rgKey1 = SH.Range("B1:B" & lngRow)
    
13.     Set rgKey2 = SH.Range("A1:A" & lngRow)
    
14.    
    
15.     For lngRow = 1 To 30
    
16.         arr(lngRow, 2) = InStr(arr(lngRow, 1), "X")
    
17.     Next
    
18.    
    
19.     rgSource = arr
    
20.   
    
21.     SH.Sort.SortFields.Clear
    
22.     SH.Sort.SortFields.Add Key:=rgKey1, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
23.     SH.Sort.SortFields.Add Key:=rgKey2, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
24.     With SH.Sort
    
25.         .SetRange rgSource
    
26.         .Header = xlGuess
    
27.         .MatchCase = False
    
28.         .Orientation = xlTopToBottom
    
29.         .SortMethod = xlPinYin
    
30.         .Apply
    
31.     End With
    
32.    
    
33.     rgKey1.ClearContents
    
34. End Sub

复制代码