为什么我的排序出现异常？

cui26896

gmts 发表于 2022-5-24 21:51
老师，试过，也是一样的，女生的排名号不连续

我不知道你所说的还是一样，是什么还是一样，下图是我写代码的运行结果截图，完全没有你所说的情况。

gmts

cui26896 发表于 2022-5-25 08:16
我不知道你所说的还是一样，是什么还是一样，下图是我写代码的运行结果截图，完全没有你所说的情况。

...

女生第8名后面是14，15，16，19名，而不是9，10，11，12名的l连续排名

cui26896

提问题就没有说明白，你这个那有什么排序的问题，就是个简单循环就解决问题的事

1. Sub test()
   
2.   Dim ar As Variant, i&, j&, mr&, lngct(1) As Long
   
3.   With Sheet1
   
4.     mr = .Cells(Rows.Count, 1).End(xlUp).Row
   
5.     ar = .Range("a1:l" & mr + 1)
   
6.     .Range("a1:l" & mr + 1).Sort .Range("a2"), , , , , , , 2
   
7.     .Range("a1").Resize(UBound(ar), UBound(ar, 2)) = ar
   
8.   End With
   
9.     For i = 2 To UBound(ar) - 1
   
10.       If ar(i, 1) = "男" Then
    
11.         lngct(0) = lngct(0) + 1
    
12.         ar(i, UBound(ar, 2)) = "男-" & lngct(0)
    
13.         Else
    
14.           lngct(1) = lngct(1) + 1
    
15.           ar(i, UBound(ar, 2)) = "女-" & lngct(1)
    
16.       End If
    
17.     Next
    
18.   Sheet2.Activate
    
19.   Sheet2.Range("a1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
20. End Sub
    

复制代码

gmts

cui26896 发表于 2022-5-25 14:20
提问题就没有说明白，你这个那有什么排序的问题，就是个简单循环就解决问题的事

请你看清楚我的图片，我是以平均分作为依据作为分开男女学生的排名次结果，即男生从第1名到N名，女生也是从第1名到N名

cui26896

1. Sub test2()
   
2.   Dim ar As Variant, br As Variant, i&, j&, mr&, p&, lngct(1) As Long
   
3.   With Sheet1
   
4.     mr = .Cells(Rows.Count, 1).End(xlUp).Row
   
5.     ar = .Range("a1:l" & mr)
   
6.     .Range("a1:l" & mr).Sort .Range("a2"), , , , , , , 2
   
7.     p = 1
   
8.     For i = p + 1 To UBound(ar)
   
9.       If Cells(i, 1) <> Cells(i + 1, 1) Then
   
10.         .Range("a" & p + 1 & ":l" & i).Sort .Range("f" & p + 1), 2, , , , , , 2
    
11.         p = i
    
12.       End If
    
13.     Next
    
14.     br = .Range("a1").Resize(mr, UBound(ar, 2))
    
15.     .Range("a1").Resize(mr, UBound(ar, 2)) = ar
    
16.   End With
    
17.     For i = 2 To UBound(br) - 1
    
18.       If br(i, 1) = "男" Then
    
19.         lngct(0) = lngct(0) + 1
    
20.         br(i, UBound(ar, 2)) = br(i, 1) & "-" & lngct(0)
    
21.         Else
    
22.           lngct(1) = lngct(1) + 1
    
23.           br(i, UBound(ar, 2)) = br(i, 1) & "-" & lngct(1)
    
24.       End If
    
25.     Next
    
26.   Sheet2.Activate
    
27.   Sheet2.Range("a1").Resize(UBound(br), UBound(br, 2)) = br
    
28. End Sub

复制代码

gmts

cui26896 发表于 2022-5-26 10:10

老师，还是有问题呀

cui26896

For i = 2 To UBound(br) - 1
这一句修改后没有保存，应该是
For i = 2 To UBound(br)

准提部林

Sub TEST_A1()
Dim Arr, K, xD, T$, i&
Arr = [A2:L21]
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    T = Arr(i, 1)
    If Not xD.Exists(T) Then Set xD(T) = CreateObject("Scripting.Dictionary")
    xD(T)(Arr(i, 6)) = ""
Next i
For Each K In xD.keys
    For i = 1 To xD(K).Count
        xD(K & "/" & Application.Large(xD(K).keys, i)) = i
    Next i
Next K
For i = 1 To UBound(Arr)
    T = Arr(i, 1)
    Arr(i, 1) = T & "-" & xD(T & "/" & Arr(i, 6))
Next i
[L2].Resize(UBound(Arr)) = Arr
End Sub

shenzhenyang

cui26896 发表于 2022-5-26 10:10

mr = .Cells(Rows.Count, 1).End(xlUp).Row+1

试了这样可以

gmts

准提部林 发表于 2022-5-27 11:13
Sub TEST_A1()
Dim Arr, K, xD, T$, i&
Arr = [A2:L21]

谢谢赐教，就是这样的效果