去重汇总并计算男、女、合计与各自百分比，

翁知江安

以上数据仅供参考，欢迎批评指正

shiruiqiang

建议转化成数组，否则人员一多就卡
其次，lz埋了一个雷，有重复数据，需要去重
如甲状腺结节(标黄的)：

shiruiqiang

ykcbf1100 发表于 2024-11-10 10:52
练习一下。。。

ykcbf1100老师，看一下12楼。lz埋了个雷

ykcbf1100

shiruiqiang 发表于 2024-11-10 14:38
建议转化成数组，否则人员一多就卡
其次，lz埋了一个雷，有重复数据，需要去重
如甲状腺结节(标黄的)：

是啊，居然这么多重复。
我前面写的代码还得重写一下。

先去重，再统计

ykcbf1100

先去重处理，再统计

1. Sub ykcbf()   '//2024.11.10
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     ReDim zrr(1 To r, 1 To 5)
   
10.     For i = 2 To UBound(arr)
    
11.         s = CStr(arr(i, 2))
    
12.         d1(s) = d1(s) + 1
    
13.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
14.         If Not d.exists(s) Then
    
15.             m = m + 1
    
16.             d(s) = m
    
17.             For j = 1 To UBound(arr, 2)
    
18.                 zrr(m, j) = arr(i, j)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     d.RemoveAll
    
23.     m = 0
    
24.     ReDim brr(1 To r, 1 To 8)
    
25.     For i = 1 To UBound(zrr)
    
26.         s = zrr(i, 1)
    
27.         If s <> Empty Then
    
28.             p1 = IIf(zrr(i, 4) = "男", 1, 0)
    
29.             p2 = IIf(zrr(i, 4) = "女", 1, 0)
    
30.             If Not d.exists(s) Then
    
31.                 m = m + 1
    
32.                 d(s) = m
    
33.                 brr(m, 1) = m
    
34.                 brr(m, 2) = s
    
35.                 brr(m, 3) = p1
    
36.                 brr(m, 4) = p2
    
37.                 brr(m, 5) = brr(m, 3) + brr(m, 4)
    
38.             Else
    
39.                 r = d(s)
    
40.                 brr(r, 3) = brr(r, 3) + p1
    
41.                 brr(r, 4) = brr(r, 4) + p2
    
42.                 brr(r, 5) = brr(r, 5) + 1
    
43.             End If
    
44.             brr(m, 6) = Format(brr(m, 3) / d1.Count, "0.00%")
    
45.             brr(m, 7) = Format(brr(m, 4) / d1.Count, "0.00%")
    
46.             brr(m, 8) = Format(brr(m, 5) / d1.Count, "0.00%")
    
47.         End If
    
48.     Next
    
49.     With Sheets("汇总")
    
50.         .[a4:h10000] = ""
    
51.         .[a4].Resize(m, 8) = brr
    
52.         .[a4].Resize(m, 8).Borders.LineStyle = 1
    
53.     End With
    
54.     Set d = Nothing
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "OK！"
    
57. End Sub
    

复制代码

ykcbf1100

shiruiqiang 发表于 2024-11-10 14:46
ykcbf1100老师，看一下12楼。lz埋了个雷

已修改代码，先去重处理。

ykcbf1100

继续练习，增加一个年龄组统计

ykcbf1100

年龄组统计

先按体检号去重，再统计

1. Sub ykcbf2()   '//2024.11.10
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     ReDim zrr(1 To r, 1 To 5)
   
10.     For i = 2 To UBound(arr)
    
11.         s = CStr(arr(i, 2))
    
12.         d1(s) = d1(s) + 1
    
13.         If Not d.exists(s) Then
    
14.             m = m + 1
    
15.             d(s) = m
    
16.             For j = 1 To UBound(arr, 2)
    
17.                 zrr(m, j) = arr(i, j)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     mm = m: m = 0
    
22.     ReDim brr(1 To r, 1 To 8)
    
23.     With Sheets("汇总")
    
24.         ar = .[l5:r10]
    
25.         p1 = 0: p2 = 0
    
26.         For x = 1 To UBound(ar) - 1
    
27.             If InStr(ar(x, 1), "~") = 0 Then
    
28.                 t1 = 61: t2 = 200
    
29.             Else
    
30.                 t = Split(ar(x, 1), "~")
    
31.                 t1 = Val(t(0)): t2 = Val(t(1))
    
32.             End If
    
33.             s1 = 0: s2 = 0
    
34.             For i = 1 To UBound(zrr)
    
35.                 s = zrr(i, 1)
    
36.                 If zrr(i, 5) >= t1 And zrr(i, 5) <= t2 Then
    
37.                     s1 = s1 + IIf(zrr(i, 4) = "男", 1, 0)
    
38.                     s2 = s2 + IIf(zrr(i, 4) = "女", 1, 0)
    
39.                 End If
    
40.             Next
    
41.             ar(x, 2) = s1
    
42.             ar(x, 3) = s2
    
43.             ar(x, 4) = s1 + s2
    
44.             ar(x, 5) = Format(s1 / mm, "0.00%")
    
45.             ar(x, 6) = Format(s2 / mm, "0.00%")
    
46.             ar(x, 7) = Format(ar(x, 4) / mm, "0.00%")
    
47.             p1 = p1 + s1
    
48.             p2 = p2 + s2
    
49.         Next
    
50.         ar(UBound(ar), 2) = p1
    
51.         ar(UBound(ar), 3) = p2
    
52.         ar(UBound(ar), 4) = p1 + p2
    
53.         ar(UBound(ar), 5) = Format(p1 / mm, "0.00%")
    
54.         ar(UBound(ar), 6) = Format(p2 / mm, "0.00%")
    
55.         ar(UBound(ar), 7) = Format(ar(UBound(ar), 4) / mm, "0.00%")
    
56.         .[l5:r10] = ar
    
57.     End With
    
58.     Set d = Nothing
    
59.     Application.ScreenUpdating = True
    
60.     MsgBox "OK！"
    
61. End Sub
    

复制代码