统计符合条件的个数

yueyiggjjddmm

shiruiqiang

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()    '//2025.4.15
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     arr = Range("a2:c" & r)
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1) & " " & arr(i, 2) & " " & arr(i, 3)
   
9.         d1(s) = ""
   
10.     Next
    
11.     For Each k In d1.keys
    
12.         b = Split(k)
    
13.         num = Val(b(2))
    
14.         If num <= 1000 Then p1 = 1 Else p1 = 0
    
15.         If num <= 5000 And num > 1000 Then p2 = 1 Else p2 = 0
    
16.         If num <= 10000 And num > 5000 Then p3 = 1 Else p3 = 0
    
17.         If num > 10000 Then p4 = 1 Else p4 = 0
    
18.         s = b(0)
    
19.         If Not d.exists(s) Then
    
20.             d(s) = Array(p1, p2, p3, p4)
    
21.         Else
    
22.             t = d(s)
    
23.             t(0) = t(0) + p1
    
24.             t(1) = t(1) + p2
    
25.             t(2) = t(2) + p3
    
26.             t(3) = t(3) + p4
    
27.             d(s) = t
    
28.         End If
    
29.     Next
    
30.     arr = [h3:l14]
    
31.     For i = 1 To UBound(arr)
    
32.         s = CStr(arr(i, 1))
    
33.         If d.exists(s) Then
    
34.             t = d(s)
    
35.             For j = 2 To 5
    
36.                 arr(i, j) = t(j - 2)
    
37.             Next
    
38.         End If
    
39.     Next
    
40.     [h3:l14] = arr
    
41.     Set d = Nothing
    
42.     Set d1 = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    
46. 
    

复制代码

quqiyuan

写了公式：每列公式不一
下拉
=SUMPRODUCT(IFERROR(1/COUNTIFS($A:$A,$H3,$B:$B,$B$2:$B$104,$C:$C,$C$2:$C$104)*($C$2:$C$104<=1000),))
=SUMPRODUCT(IFERROR(1/COUNTIFS($A:$A,$H3,$B:$B,$B$2:$B$104,$C:$C,$C$2:$C$104)*($C$2:$C$104<=5000)*($C$2:$C$104>1000),))
=SUMPRODUCT(IFERROR(1/COUNTIFS($A:$A,$H3,$B:$B,$B$2:$B$104,$C:$C,$C$2:$C$104)*($C$2:$C$104<=10000)*($C$2:$C$104>5000),))
=SUMPRODUCT(IFERROR(1/COUNTIFS($A:$A,$H3,$B:$B,$B$2:$B$104,$C:$C,$C$2:$C$104)*($C$2:$C$104>10000),))

飞天篮球猪

仅供参考...

翁知江安

Sub test250415()
Dim i, m As Integer, ar, br As Variant, d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Range("a1:d" & Range("a65536").End(xlUp).Row)
d2.Add "四档", 5: d2.Add "三档", 4
d2.Add "二档", 3: d2.Add "一档", 2
ReDim br(1 To 30, 1 To 5)
For i = 2 To UBound(ar)
    If Not d1.exists(ar(i, 1) & ar(i, 2) & ar(i, 3)) Then
        d1(ar(i, 1) & ar(i, 2) & ar(i, 3)) = ""
        If ar(i, 3) > 10000 Then
            ar(i, 4) = "四档"
         Else
            If ar(i, 3) > 5000 Then
                ar(i, 4) = "三档"
            Else
                If ar(i, 3) > 1000 Then
                    ar(i, 4) = "二档"
                Else
                    ar(i, 4) = "一档"
                End If
            End If
        End If
        If Not d2.exists(ar(i, 1)) Then
            m = m + 1
            d2(ar(i, 1)) = m
            br(d2(ar(i, 1)), 1) = ar(i, 1)
        End If
        br(d2(ar(i, 1)), d2(ar(i, 4))) = br(d2(ar(i, 1)), d2(ar(i, 4))) + 1
    End If
Next
[h3].Resize(12, 4).ClearContents
[h3].Resize(m, 4) = br
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

cdcn

练习。。。请指正

1122A.rar (21.61 KB, 下载次数: 1)

2025-4-15 21:46 上传

点击文件名下载附件

yynrzwh