[已解决]如何实现数字排序

grf1973

乐乐2006201506 发表于 2016-5-16 19:04
我的意思是，能不能实现相同格式情况下，不同级别的排序实现动态化排序，比如，6-23行是9个名次，24行至33行 ...

在原来的代码上小改一下即可，限制排序的区域。

1. Sub main()
   
2.     Call 排序(6, 23)
   
3.     Call 排序(24, 33)
   
4.     Call 排序(34, 45)
   
5. End Sub
   
6. Sub 排序(r1, r2)          '对以r1起始行，r2结束行的区域进行排序
   
7.     Dim cel As Range
   
8.     crr = Array(1, 26, 27)        '要合并、撤销合并所在的列
   
9.     For i = r1 To r2
   
10.         Cells(i, "AB") = i     '辅助列，用于合并单元格内的排序
    
11.         For k = 0 To 2
    
12.             j = crr(k)
    
13.             Cells(i, j).UnMerge      '取消合并单元格
    
14.             If Cells(i, j) = "" Then Cells(i, j) = Cells(i - 1, j)      '合并单元格取消后，给下面的空值赋值
    
15.         Next
    
16.     Next
    
17.     Range("A" & r1 & ":AB" & r2).Sort key1:=Cells(r1, "aa"), key2:=Cells(r1, "ab")    '排序
    
18.     Application.DisplayAlerts = False
    
19.     For i = r1 To r2         '合并单元格
    
20.         For k = 0 To 2
    
21.             j = crr(k)
    
22.             Set cel = Cells(i, j)
    
23.             If cel = cel.Offset(-1, 0) And Len(cel) > 0 Then cel.Offset(-1, 0).Resize(2, 1).Merge
    
24.         Next
    
25.     Next
    
26.     [ab:ab] = ""     '清空辅助列
    
27.     Application.DisplayAlerts = True
    
28. End Sub
    

复制代码

grf1973

请看附件。

乐乐2006201506

Sub main()
    Call 排序(6, 23)
    Call 排序(24, 33)
    Call 排序(34, 45)
End Sub
Sub 排序(r1, r2)          '对以r1起始行，r2结束行的区域进行排序
    Dim cel As Range
    crr = Array(1, 26, 27)        '要合并、撤销合并所在的列
    For i = r1 To r2
        Cells(i, "AB") = i     '辅助列，用于合并单元格内的排序
        For k = 0 To 2
            j = crr(k)
            Cells(i, j).UnMerge      '取消合并单元格
            If Cells(i, j) = "" Then Cells(i, j) = Cells(i - 1, j)      '合并单元格取消后，给下面的空值赋值
        Next
    Next
    Range("A" & r1 & ":AB" & r2).Sort key1:=Cells(r1, "z"), Order1:=xlDescending, key2:=Cells(r1, "ab")    '排序
    Application.DisplayAlerts = False
    For i = r1 To r2         '合并单元格
        For k = 0 To 2
            j = crr(k)
            Set cel = Cells(i, j)
            If cel = cel.Offset(-1, 0) And Len(cel) > 0 Then cel.Offset(-1, 0).Resize(2, 1).Merge
        Next
    Next
    [ab:ab] = ""     '清空辅助列
    Application.DisplayAlerts = True
End Sub