求助论坛里的高手实现类似countifs的功能

戎马书生222

      思考了一天没啥思路，求助高手实现类似countifs的功能。模拟效果见附件

wang-way

要把原始数据排名数据类型改为常规 才能执行

1. Sub loopsql()
   
2.     ' 设置wb为当前工作簿
   
3.     Set wb = Application.ThisWorkbook
   
4.     '' 设置sht为指定名称的工作表，引号内填写工作表名称
   
5.     Set sht = wb.Worksheets("名次统计")
   
6.     ' 获取工作簿的完整路径，赋值给fp
   
7.     fp = wb.FullName
   
8.     ' 使用With语句，方便对工作表Sht进行多次操作
   
9.     With sht
   
10.         ' 获取第1行中最右侧数据列的列号
    
11.         ecol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
12.         For j = 1 To ecol Step 3
    
13.             zh = .Cells(2, j)
    
14.             mc = Replace(Replace(.Cells(1, j + 2).Value, "前", ""), "名", "")
    
15.             SQL = "select 班级,Count(班级) from [Sheet1$A1:C] where 组合='" & zh & "' and 组合内名次<" & mc & " group by 班级 "
    
16.            Debug.Print SQL
    
17.            SqlToRng fp, SQL, .Cells(2, j + 1)
    
18.         Next j
    
19.     End With
    
20.     'SqlToRng fp, SQL, rng
    
21. End Sub
    
22. ' 过程结束
    
23. '' 代码功能：根据SQL语句查询结果 输出到目标单元格区域
    
24. '' 参数说明
    
25. '' 参数【Datapath 】：工作簿的文件路径
    
26. '' 参数【     SQL    】：SQL查询语句
    
27. '' 参数【     Rng    】：目标单元格区域
    
28. '' 调用示范：SqlToRng fp,sql,rng
    
29. Sub SqlToRng(ByVal DataPath As String, ByVal SQL As String, ByVal rng As Range)
    
30.     'Debug.Print SQL
    
31.     '' 判断工作簿路径是否存在，若不存在弹窗提示，退出函数
    
32.     If Len(DataPath) = 0 Or Len(Dir(DataPath)) = 0 Then
    
33.         MsgBox "数据源地址为空或者数据源文件不存在！", vbInformation, "QQ84857038"
    
34.         '' 退出
    
35.         Exit Sub
    
36.     End If
    
37.     '' 判断SQL语句是否为空
    
38.     If Len(SQL) = 0 Then
    
39.         MsgBox "SQL语句不能为空！", vbInformation, "QQ84857038"
    
40.         '' 退出
    
41.         Exit Sub
    
42.     End If
    
43.     '' 声明连接器变量cnn，结果集变量rs，引擎字符串变量dataEngine
    
44.     Dim CNN, rs, dataEngine  As String
    
45.     '' 判断Excel版本，选择相应的引擎
    
46.     Select Case Application.Version * 1
    
47.     Case Is <= 11
    
48.         dataEngine = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
    
49.     Case Is >= 12
    
50.         dataEngine = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
    
51.     End Select
    
52.     '' 创建ADO Connection 连接器
    
53.     Set CNN = CreateObject("ADODB.Connection")
    
54.     '' 打开数据源
    
55.     CNN.Open dataEngine & DataPath
    
56.     '' 执行查询，返回记录集
    
57.     Set rs = CNN.Execute(SQL)
    
58.     '' 把数据集转置为一个数组
    
59.     If Not (rs.EOF And rs.BOF) Then
    
60.         rng.CopyFromRecordset rs
    
61.     End If
    
62.     '' 关闭记录集
    
63.     rs.Close
    
64.     '' 关闭连接器
    
65.     CNN.Close
    
66.     '' 释放对象
    
67.     Set rs = Nothing
    
68.     Set CNN = Nothing
    
69. End Sub
    

复制代码

wang-way

你自己修改吧 改成计数

戎马书生222

是分4个组合统计。模拟效果见下图

wang-way

练手  

1. '' 代码功能：筛选组合内名次小于200的
   
2. Public Function CountIf2(ByVal Rng As Range, ParamArray ar()) As Integer
   
3.     '' 将范围Rng的值赋给数组Arr
   
4.     arr = Rng.Value
   
5.     ' 变量 i 从数组Arr第一维 最小索引开始，遍历至最大索引
   
6.     '' 变量 j 从数组Arr第二维 最小索引开始，遍历至最大索引
   
7.     Debug.Print UBound(ar) + 1
   
8.     n = 0
   
9.     For i = LBound(arr) To UBound(arr)
   
10.         b = 0
    
11.         For j = LBound(arr, 2) To UBound(arr, 2)
    
12.             On Error Resume Next
    
13.             t = Evaluate(arr(i, j) & ar(j - 1))
    
14.             If t = "Error 2029" Then
    
15.                 If Evaluate("""" & arr(i, j) & """" & ar(j - 1)) Then b = b + 1
    
16.                 Err.Clear
    
17.                 On Error GoTo 0
    
18.             Else
    
19.               If t Then b = b + 1
    
20.             End If
    
21.         Next j
    
22.         If b = UBound(ar) + 1 Then n = n + 1
    
23.     Next i
    
24.     CountIf2 = n
    
25. End Function
    
26. '' 过程结束

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.18
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     a = [{"政史地","物化生","物化地","政史生"}]
   
6.     b = [{420,190,70,100}]
   
7.     With Sheets("Sheet1")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .[a1].Resize(r, 3)
   
10.     End With
    
11.     ReDim brr(1 To r, 1 To UBound(a) * 3)
    
12.     For x = 1 To UBound(a)
    
13.         d.RemoveAll
    
14.         n = n + 3
    
15.         m = 0
    
16.         For i = 2 To UBound(arr)
    
17.             If arr(i, 3) = a(x) Then
    
18.                 If arr(i, 2) <= b(x) Then
    
19.                     s = a(x) & "|" & arr(i, 1)
    
20.                     If Not d.exists(s) Then
    
21.                         m = m + 1
    
22.                         d(s) = m
    
23.                         brr(m, n - 2) = a(x)
    
24.                         brr(m, n - 1) = arr(i, 1)
    
25.                         brr(m, n) = 1
    
26.                     Else
    
27.                         r = d(s)
    
28.                         brr(r, n) = brr(r, n) + 1
    
29.                     End If
    
30.                 End If
    
31.             End If
    
32.         Next
    
33.     Next
    
34.     With Sheets("名次统计")
    
35.         .UsedRange.UnMerge
    
36.         .UsedRange.Offset(1).ClearContents
    
37.         .[a2].Resize(100, n) = brr
    
38.         zr = Array(1, 4, 7, 10)
    
39.         For j = 0 To UBound(zr)
    
40.             r = .Cells(Rows.Count, zr(j)).End(3).Row
    
41.             Dim rng As Range
    
42.             For i = r To 2 Step -1
    
43.                 Set rng = ActiveSheet.Cells(i, zr(j))
    
44.                 Set Rng1 = rng.Offset(-1)
    
45.                 If rng = Rng1 Then
    
46.                     ActiveSheet.Cells(i, zr(j)).Offset(-1).Resize(2).Merge
    
47.                 End If
    
48.             Next
    
49.         Next
    
50.     End With
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码

戎马书生222

ykcbf1100 发表于 2024-6-18 08:26
参与一下。。。

太感谢了。论坛热心人一个。