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

cai5926270

yes_cn 发表于 2024-9-10 15:37
用函数公式：

=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, ...

好的谢谢。得到积分只是要做的工作的一部分

grf1973

排序之后就不用字典了。只要判断上下两行是否同组，同组中是否分数相同即可。

songshihai

公式也简单!!

cai5926270

好的，谢谢

Qs18

1. 
   
2. Sub qs()
   
3.     Dim Sql$, line&, i&, arr
   
4.     Application.ScreenUpdating = False
   
5.      Set cnn = CreateObject("adodb.connection")
   
6.     Set rst = CreateObject("ADODB.RecordSet")
   
7.     With cnn
   
8.         .Open "Provider=Microsoft.Ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
   
9.         Sql = "select 序号,班级,座号,小组,标记,姓名,得分,IIF( 积分 IS NULL, 0, 积分) as 积分 from [数据$a:h] ORDER BY 班级 ASC, 小组 ASC,得分 DESC"
   
10.        End With
    
11.        rst.Open Sql, cnn, 1, 3
    
12.     fldCount = rst.Fields.Count
    
13.     RowCount = rst.RecordCount
    
14.     ReDim headers(1 To fldCount)
    
15.     For i = 1 To fldCount
    
16.         headers(i) = rst.Fields(i - 1).Name
    
17.     Next i
    
18.     ReDim arr(1 To RowCount, 1 To fldCount)
    
19.     rst.MoveFirst
    
20.     For i = 1 To RowCount
    
21.         For j = 1 To fldCount
    
22.             If IsNull(rst.Fields(j - 1).Value) Then
    
23.                 arr(i, j) = 0
    
24.             Else
    
25.                 arr(i, j) = rst.Fields(j - 1).Value
    
26.             End If
    
27.         Next j
    
28.         rst.MoveNext
    
29.     Next i
    
30.     s = ""
    
31.   For i = 1 To UBound(arr)
    
32.    
    
33.         If s <> arr(i, 2) & "|" & arr(i, 4) Then
    
34.             r = i
    
35.             arr(r, 8) = 1
    
36.         
    
37.         Else
    
38.             If arr(i, 7) = arr(i - 1, 7) Then arr(i - 1, 8) = 0
    
39.         
    
40.         End If
    
41.   s = arr(i, 2) & "|" & arr(i, 4)
    
42.   Next
    
43.     Sheet2.Range("j1").Resize(1, UBound(arr, 2)) = headers
    
44.     Sheet2.Range("j2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
45.      rst.Close: cnn.Close
    
46.     Set rst = Nothing: Set cnn = Nothing
    
47.     Application.ScreenUpdating = True
    
48. End Sub
    
49. 
    

复制代码

Qs18

试试。。。。。。

Qs18

试试。。。。。。

yynrzwh

Sub test()

Set d = VBA.CreateObject("scripting.dictionary")
With Sheet1
    .Range("a1").CurrentRegion.Sort key1:=.[d2], order1:=xlAscending, key2:=.[g2], order2:=xlDescending, Header:=xlYes
    .Range("a1").CurrentRegion.Offset(1, 7) = ""
    ar = .Range("a1").CurrentRegion
    For i = 2 To UBound(ar)
        s = ar(i, 4)
        If Not d.exists(s) Then
            If ar(i, 7) = ar(i + 1, 7) Then
                ar(i, 8) = 0
            Else
                ar(i, 8) = 1
            End If
            d(s) = ""
        Else
            ar(i, 8) = 0
        End If
    Next
    .Range("a1").CurrentRegion = ar
End With
End Sub

cai2532

留下脚印学习了。

cai5926270

感谢各位大佬的热心帮助问题已解决。