VBA年龄段统计

shiruiqiang

chj6533 发表于 2023-3-15 19:49
谢谢！。不知能不能把 区间段 做成一个数组，，让它循环越来，形成双循环，就好了

按每个年龄分用的着，否则如要求的时间段没必要

chj6533

shiruiqiang 发表于 2023-3-15 20:05
按每个年龄分用的着，否则如要求的时间段没必要

谢谢。。。。。。。。。。。。。。。。。。

grf1973

chj6533 发表于 2023-3-15 17:27
还有个

我以为特地不统计的

ykcbf1100

上个全年龄段的吧。

全党

字典嵌套，多条件选择用的select case，语句略显复杂，但是好理解。

那时雨

虽然是之前的帖子，但用来练手不错！

1. Sub Test()
   
2.     Dim dic As Object, d, arr, brr(), r&, n%, LastRow&
   
3.     Set dic = CreateObject("Scripting.Dictionary")
   
4. Rem 先遍历字典汇总
   
5.     arr = ActiveSheet.UsedRange
   
6.     For r = 2 To UBound(arr)
   
7.         dic(arr(r, 1)) = dic(arr(r, 1)) + 1
   
8.     Next r
   
9.     [H2].Resize(dic.Count, 2) = Application.Transpose(Array(dic.Keys, dic.Items))
   
10. Rem 将相同行政属地的年龄加入同一行政属地的字典中
    
11.     For Each d In dic
    
12.         For r = 2 To UBound(arr)
    
13.             If d = arr(r, 1) Then
    
14.                 n = n + 1
    
15.                 ReDim Preserve brr(1 To n)
    
16.                 brr(n) = arr(r, 3)
    
17.             End If
    
18.         Next r
    
19.         dic(d) = brr
    
20.         n = 0: Erase brr()
    
21.     Next d
    
22. Rem 将H列的行政地名作为字典关键字遍历其键值
    
23.     LastRow = Cells(Rows.Count, "H").End(xlUp).Row '定位合计行
    
24.     arr = Range("H1:M" & LastRow)
    
25.     For r = 2 To dic.Count + 1
    
26.         For Each d In dic(arr(r, 1))
    
27.             Select Case d
    
28.                 Case 0 To 14
    
29.                     arr(r, 3) = arr(r, 3) + 1
    
30.                 Case 15 To 64
    
31.                     arr(r, 4) = arr(r, 4) + 1
    
32.                 Case 65 To 79
    
33.                     arr(r, 5) = arr(r, 5) + 1
    
34.                 Case Else
    
35.                     arr(r, 6) = arr(r, 6) + 1
    
36.             End Select
    
37.         Next d
    
38.         arr(LastRow, 2) = arr(LastRow, 2) + arr(r, 2)
    
39.         arr(LastRow, 3) = arr(LastRow, 3) + arr(r, 3)
    
40.         arr(LastRow, 4) = arr(LastRow, 4) + arr(r, 4)
    
41.         arr(LastRow, 5) = arr(LastRow, 5) + arr(r, 5)
    
42.         arr(LastRow, 6) = arr(LastRow, 6) + arr(r, 6)
    
43.     Next r
    
44.     Range("H1:M" & LastRow) = arr
    
45. End Sub

复制代码