求助各位大神一个宏程序进行非正常排名

lmx3517

请教各位老师和版主用什么"宏"的程序，可以进行非正常排序。排序要求为以总分列进行递减式排序，如果有重复的单位出现则无论总分再大，它也将排在不重复单位的后面。
例如：序号1、15、16均为天津，按照正常排名的名次分别为1、2、6名。但是第一名有天津，后2个天津应排在所有不重复单位的后面。排在后面的排名也按照递减排序。具体见附件，在此先谢谢各位老师和版主。

ykcbf1100

附件供参考。。。

ykcbf1100

排序。。。

1. Sub ykcbf()   '//2024.12.12
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .UsedRange.Columns.Count
   
7.         For i = 5 To r
   
8.             s = .Cells(i, 3).Value
   
9.             d(s) = d(s) + 1
   
10.             If d(s) > 1 Then
    
11.                 .Cells(i, c + 1).Value = 1
    
12.             Else
    
13.                 .Cells(i, c + 1).Value = 9
    
14.             End If
    
15.         Next
    
16.         Set Rng = .Cells(5, 1).Resize(r - 4, c + 1)
    
17.         With Rng
    
18.             .Parent.Sort.SortFields.Clear
    
19.             .Sort key1:=.Item(c + 1), order1:=2, key2:=.Item(c), order2:=2, Header:=2
    
20.         End With
    
21.         .Columns(c + 1) = ""
    
22.     End With
    
23.     Set d = Nothing
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    
27. 
    

复制代码

loirol

ykcbf1100 发表于 2024-12-12 13:00
附件供参考。。。

这个算法之前要sort一下G列

如果天津48在天津60前面，结果就不对了

ykcbf1100

loirol 发表于 2024-12-12 13:17
这个算法之前要sort一下G列

如果天津48在天津60前面，结果就不对了

第一次出现的总是排在前面的，结果应该没问题。

最终是按总分来的。


不过，你说的也有道理。如果先进行一次按名次排序，应该更合理一点。

loirol

ykcbf1100 发表于 2024-12-12 13:19
第一次出现的总是排在前面的，结果应该没问题。

最终是按总分来的。

三个天津也要按大小排的吧，如果初始状态是图一，排完结果是图2

ykcbf1100

loirol 发表于 2024-12-12 13:24
三个天津也要按大小排的吧，如果初始状态是图一，排完结果是图2

排序要求为以总分列进行递减式排序，如果有重复的单位出现则无论总分再大，它也将排在不重复单位的后面。
楼主是这么说的。所以，分数高也不一定排在前面的。

翁知江安

Sub paim()
Dim i, j, k, m, irow
Dim t
t = Timer
Dim ar, br, cr
Dim d, d1 As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
irow = Sheet1.[L65536].End(xlUp).Row
ar = Sheet1.Range("j1:p" & irow)
For i = 5 To irow
   d1(ar(i, 4) & ar(i, 5) & ar(i, 6)) = ar(i, 3)
   If Not d.exists(ar(i, 3)) Then
      d(ar(i, 3)) = ar(i, 7)
      Else
        If ar(i, 7) > d(ar(i, 3)) Then
           d(ar(i, 3)) = ar(i, 7)
         End If
       End If
Next
Sheet1.[a5].Resize(100, 7).ClearContents
Sheet1.[c5].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
Sheet1.[g5].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
Sheet1.Range("a4:g" & d.Count + 1).Sort key1:=Columns("g"), order1:=xlDescending, Header:=xlYes
br = Sheet1.[a5].Resize(d.Count, 7)
For j = 1 To d.Count
  For i = 5 To irow
If br(j, 3) = ar(i, 3) And br(j, 7) = ar(i, 7) Then
   br(j, 2) = ar(i, 2)
   For k = 4 To 6
   br(j, k) = ar(i, k)
   Next
   ar(i, 3) = ""
   End If
Next
Next
Sheet1.[a5].Resize(d.Count, 7) = br
ReDim cr(1 To 10, 1 To 7)
For i = 5 To irow
   If ar(i, 3) <> "" Then
   m = m + 1
   cr(m, 2) = ar(i, 2)
   For k = 4 To 7
   cr(m, k) = ar(i, k)
   Next
   cr(m, 3) = d1(cr(m, 4) & cr(m, 5) & cr(m, 6))
   End If
Next
Sheet1.Cells(5 + d.Count, 1).Resize(m, 7) = cr
Sheet1.Cells(5 + d.Count, 1).Resize(m, 7).Sort key1:=Columns("g"), order1:=xlDescending, Header:=xlNo
For i = 5 To irow
   Sheet1.Cells(i, 1) = i - 4
Next
MsgBox Timer - t
MsgBox "ok"
End Sub

翁知江安

为测试程序，另行增加了俩行数据，请知悉。以上供参考，欢迎批评指正。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Columns(1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
8.         .Range("a5:g" & r).Sort key1:=.Range("g5"), order1:=xlDescending, Header:=xlNo
   
9.         arr = .Range("a5:g" & r)
   
10.         ReDim brr(1 To UBound(arr), 1 To 1)
    
11.         For i = 1 To UBound(arr)
    
12.             If Not d.exists(arr(i, 3)) Then
    
13.                 brr(i, 1) = 1
    
14.                 d(arr(i, 3)) = Empty
    
15.             Else
    
16.                 brr(i, 1) = 2
    
17.             End If
    
18.         Next
    
19.         .Range("h5").Resize(UBound(brr), 1) = brr
    
20.         .Range("a5:h" & r).Sort key1:=.Range("h5"), order1:=xlAscending, key2:=.Range("g5"), order2:=xlDescending, Header:=xlNo
    
21.         .Columns(8).Clear
    
22.         For i = 5 To r
    
23.             .Cells(i, 2) = i - 4
    
24.         Next
    
25.     End With
    
26. End Sub
    

复制代码