求救：根据得分情况计算积分

cai5926270

有一个问题困扰很久一直没有思路解决向大家请教了：

要求如下：
1.积分计算方法：
(1)小组得分最高的组员积1分，其他组员积0分；
(2)若有两个或两个以上同分并且是最高，则视为小组没有最高分， 则每个组员都积0分；
2.每一个小组人数不定；
3.数据图和效果图如图1和图2所示；

usedrange

1. Sub tt()
   
2.     Dim ar, i%, dic, k
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheets("数据")
   
5.         Set ar = .[a1].CurrentRegion
   
6.         ar.Sort key1:="小组", order1:=1, key2:="得分", order2:=2, Header:=xlYes
   
7.         For i = 2 To UBound(ar.Value)
   
8.             dic(ar(i, 4).Value) = dic(ar(i, 4).Value) + 1
   
9.             .Cells(i, "h") = 0
   
10.         Next i
    
11.         For Each k In dic.keys
    
12.             For i = 2 To UBound(ar.Value)
    
13.                 If k = ar(i, 4) Then
    
14.                     Set m = .Range("g" & i & ":g" & i + dic(k) - 1).Find(ar(i, 7))
    
15.                     If m.Row = i Then .Cells(i, "h") = 1
    
16.                     Exit For
    
17.                 End If
    
18.             Next i
    
19.         Next k
    
20.     End With
    
21.     Set ar = Nothing
    
22.     Set dic = Nothing
    
23. End Sub

复制代码

chxw68

详见附件。

清风竹-

Sub 积分()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
m = [a65536].End(3).Row
Range("a2:g" & m).Sort Key1:=Range("b2"), Order1:=xlAscending, Key2:=Range("d2") _
        , Order2:=xlAscending, Key3:=Range("g2"), Order3:=xlDescending, Header:=xlGuess
arr = Sheet1.Range("d1:g" & m + 1)
ReDim brr(1 To UBound(arr), 1 To 1)

For i = 2 To UBound(arr) - 1
    ss = arr(i, 1) & arr(i, 4)
    If Not d.Exists(arr(i, 1)) Then
       d1(ss) = i
       d(arr(i, 1)) = i
       brr(i - 1, 1) = 1
     Else
       brr(i - 1, 1) = 0
      If d1.Exists(ss) Then
        brr(d1(ss) - 1, 1) = 0
       End If
    End If
Next
Cells(2, "h").Resize(UBound(arr), 1) = brr
End Sub

usedrange

参与一下，看看是不是这个结果

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.10
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("数据")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 8)
   
7.         For i = 2 To UBound(arr)
   
8.             s = arr(i, 4)
   
9.             If Not d.exists(s) Then
   
10.                 d(s) = arr(i, 7)
    
11.             Else
    
12.                 d(s) = IIf(d(s) < arr(i, 7), arr(i, 7), d(s))
    
13.             End If
    
14.         Next
    
15.         For i = 2 To UBound(arr)
    
16.             s = arr(i, 4)
    
17.             arr(i, 8) = 0
    
18.             For Each k In d.keys
    
19.                 If s = k Then
    
20.                     If arr(i, 7) = d(k) Then
    
21.                         arr(i, 8) = 1
    
22.                         d1(s) = d1(s) + 1
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.         Next
    
27.         .[a1].Resize(r, 8) = arr
    
28.         For i = 2 To r
    
29.             If .Cells(i, 8) = 1 Then
    
30.                 s = .Cells(i, 4)
    
31.                 If d1(s) > 1 Then .Cells(i, 8) = 0
    
32.             End If
    
33.         Next
    
34.     End With
    
35.     MsgBox "OK！"
    
36. End Sub
    
37. 
    

复制代码

cai5926270

usedrange 发表于 2024-9-10 15:08
参与一下，看看是不是这个结果

谢谢，不过有些积分计算是错的

cai5926270

清风竹- 发表于 2024-9-10 15:02
Sub 积分()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionar ...

太好了，感谢

yes_cn

用函数公式：

=IF(AND(D2=D1,G2=MAX(IF(D:D=D2,G:G))),IF(COUNTIFS(D:D,D2,G:G,MAX(IF(D:D=D2,G:G)))=1,1,0),IF(G2=MAX(IF(D:D=D2,G:G)),IF(COUNTIFS(D:D,D2,G:G,MAX(IF(D:D=D2,G:G)))=1,1,0),0))

按Ctrl+Shift+Enter