人员信息按照年龄范围与工龄范围汇总

158807837

1. Sub 新建工作表()
   
2. On Error Resume Next
   
3. 
   
4.     tmp = InputBox("请在文本框中输入新建工作表名称：" & Chr(13) & Chr(13) & "按【确定】增加，否则请按【取消】。", "〖点解点解〗")
   
5.     If tmp = "" Then tmp = Sheet3.Name
   
6.     For Each n In Sheets
   
7. If tmp = n.Name Then
   
8. tmp = n.Name: k = 1
   
9. Exit For
   
10. End If
    
11. Next
    
12. If k <> 1 Then
    
13. Sheets.Add After:=Sheets(Sheets.Count)
    
14. ActiveSheet.Name = tmp
    
15. End If
    
16. 
    
17. With Sheets(tmp)
    
18. .Cells.Clear
    
19. .Cells.RowHeight = Cells(2, 5)
    
20. .Cells.ColumnWidth = Cells(2, 6)
    
21. .Cells.HorizontalAlignment = xlCenter
    
22. .Cells.VerticalAlignment = xlCenter
    
23. End With
    
24. Dim c As Range
    
25. Dim arr
    
26. arr = Sheet2.UsedRange
    
27. Dim d(1 To 6) As Object
    
28. Set dic = CreateObject("Scripting.Dictionary")
    
29. Set d(1) = CreateObject("Scripting.Dictionary")
    
30. Set d(2) = CreateObject("Scripting.Dictionary")
    
31. Set d(3) = CreateObject("Scripting.Dictionary")
    
32. Set d(4) = CreateObject("Scripting.Dictionary")
    
33. Set d(5) = CreateObject("Scripting.Dictionary")
    
34. Set d(6) = CreateObject("Scripting.Dictionary")
    
35. For i = 2 To UBound(arr)
    
36. If arr(i, 17) = "中专" Or arr(i, 17) = "高中" Then
    
37. arr(i, 17) = "高中（含中专）"
    
38. ElseIf IsNumeric(Application.Match(arr(i, 17), Split(Cells(4, 4), ","), 0)) Then
    
39. arr(i, 17) = arr(i, 17)
    
40. Else: arr(i, 17) = "高中以下"
    
41. End If
    
42. arr(i, 22) = Val(Split(arr(i, 22), "年")) * 12 + Val(Split(Split(arr(i, 22), "年")(1), "月"))
    
43. 
    
44. dic(arr(i, 4)) = dic(arr(i, 4)) + 1
    
45. d(1)(arr(i, 2) & arr(i, 4)) = d(1)(arr(i, 2) & arr(i, 4)) + 1 '年龄
    
46. d(2)(arr(i, 22) & arr(i, 4)) = d(2)(arr(i, 22) & arr(i, 4)) + 1 '司龄
    
47. d(3)(arr(i, 17) & arr(i, 4)) = d(3)(arr(i, 17) & arr(i, 4)) + 1 '学历
    
48. d(4)(arr(i, 12) & arr(i, 4)) = d(4)(arr(i, 12) & arr(i, 4)) + 1  '岗位
    
49. d(5)(arr(i, 6) & arr(i, 4)) = d(5)(arr(i, 6) & arr(i, 4)) + 1   '职等
    
50. d(6)(arr(i, 14) & arr(i, 4)) = d(6)(arr(i, 14) & arr(i, 4)) + 1 '性别
    
51. Next
    
52. m = 5
    
53. For i = 2 To 7
    
54. aj = Split(Cells(i, 3), ",")
    
55. bj = Split(Cells(i, 4), ",")
    
56. ReDim sj(UBound(aj))
    
57. For j = 0 To UBound(aj)
    
58. sj(j) = Split(aj(j), "-")
    
59. Next
    
60. With Sheets(tmp)
    
61. .Cells(m - 3, 2) = Cells(i, 1)
    
62. .Cells(m - 3, 2).Font.Bold = True
    
63. .Cells(m - 2, 1) = Split(Cells(1, 3), "-")(0)
    
64. .Cells(m - 2, 2) = Split(Cells(1, 3), "-")(1)
    
65. .Range(.Cells(m - 2, 1), .Cells(m - 1, 1)).Merge
    
66. .Range(.Cells(m - 2, 2), .Cells(m - 1, 2)).Merge
    
67. With .Cells(m, 1).Resize(UBound(sj) + 1, 2)
    
68. .Value = Application.Transpose(Application.Transpose(sj))
    
69. End With
    
70. With .Cells(m, 2).Resize(UBound(sj) + 1, 1)
    
71. .Font.Bold = True
    
72. .Interior.ColorIndex = Cells(2, 7)
    
73. End With
    
74. For j = 0 To UBound(bj)
    
75. .Cells(m - 2, j * 2 + 3) = bj(j)
    
76. .Range(.Cells(m - 2, j * 2 + 3), .Cells(m - 2, j * 2 + 4)).Merge
    
77. .Cells(m - 1, j * 2 + 3) = "人数"
    
78. .Cells(m - 1, j * 2 + 4) = "占比"
    
79. Next
    
80. .Cells(m - 2, 3 + (UBound(bj) + 1) * 2) = "合计"
    
81. .Range(.Cells(m - 2, 3 + (UBound(bj) + 1) * 2), .Cells(m - 1, 3 + (UBound(bj) + 1) * 2)).Merge
    
82. .Cells(m - 2, 4 + (UBound(bj) + 1) * 2) = "占比"
    
83. .Range(.Cells(m - 2, 4 + (UBound(bj) + 1) * 2), .Cells(m - 1, 4 + (UBound(bj) + 1) * 2)).Merge
    
84. .Cells(m + UBound(sj) + 1, 1) = "合计"
    
85. .Range(.Cells(m + UBound(sj) + 1, 1), .Cells(m + UBound(sj) + 1, 2)).Merge
    
86. Set c = .Range(.Cells(m - 2, 1), .Cells(m + UBound(sj) + 1, 4 + (UBound(bj) + 1) * 2))
    
87. c.Borders.LineStyle = xlContinuous
    
88. c.BorderAround xlContinuous, xlMedium
    
89. .Range(.Cells(m - 2, 1), .Cells(m - 1, 4 + (UBound(bj) + 1) * 2)).Interior.ColorIndex = Cells(2, 8)
    
90. crr = .Range(.Cells(m - 2, 1), .Cells(m + UBound(sj) + 1, 4 + (UBound(bj) + 1) * 2))
    
91. For x = 3 To UBound(crr) - 1
    
92. For y = 3 To UBound(crr, 2) - 3 Step 2
    
93. crr(x, y) = d(i - 1)(crr(1, y) & crr(x, 2))
    
94. crr(x, y + 1) = Format(crr(x, y) / dic(crr(x, 2)), "0.00%")
    
95. crr(x, UBound(crr, 2) - 1) = crr(x, UBound(crr, 2) - 1) + crr(x, y)
    
96. crr(UBound(crr), y) = crr(UBound(crr), y) + crr(x, y)
    
97. crr(UBound(crr), UBound(crr, 2) - 1) = crr(UBound(crr), UBound(crr, 2) - 1) + crr(x, y)
    
98. Next
    
99. Next
    
100. For x = 3 To UBound(crr)
     
101. crr(x, UBound(crr, 2)) = Format(crr(x, UBound(crr, 2) - 1) / Val(crr(UBound(crr), UBound(crr, 2) - 1)), "0.00%")
     
102. Next
     
103. .Cells(m - 2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
     
104. End With
     
105. m = m + UBound(aj) + 6
     
106. Next
     
107. Cells(10, 3) = arr(6, 22)
     
108. Cells(11, 3) = Val(Split(arr(6, 22), "年").Value)
     
109. Cells(12, 3) = Val(Split(Split(arr(12, 22), "年")(1), "月"))
     
110. End Sub

复制代码

158807837

如表中,年龄与工龄按照参数列的条件进行统计
d(1)(arr(i, 2) & arr(i, 4)) = d(1)(arr(i, 2) & arr(i, 4)) + 1 '年龄
d(2)(arr(i, 22) & arr(i, 4)) = d(2)(arr(i, 22) & arr(i, 4)) + 1 '司龄
这报表自己做到这两天,没有想出好的方法.想是取每个条件参数的后面最大的数字,循环减前面的单元格,那就固定死了,有更改就能以调整

fjmxwrs

158807837 发表于 2015-11-28 22:48
如表中,年龄与工龄按照参数列的条件进行统计
d(1)(arr(i, 2) & arr(i, 4)) = d(1)(arr(i, 2) & arr(i, 4)) ...

为什么直接上附件呢?

爱疯

这样检查，比重写还麻烦。建议：
1）上传excel文件，说明题意。
2）只需上传一部分的数据，不便公开的数据可替换一下。

158807837

忘记了.

158807837

Val(Split(arr(6, 22), "年").Value) 怎么也没办法把年 月的数字提取出来成数字*12 全部替换成月

grf1973

读入数据源时以部门+年龄为key，每个分段分最小年龄，最大年龄，从for 年龄=最小年龄 To 最大年龄，提取d(key)就行了。

grf1973

x=a年b月，总月=val(split(x,"年")(0))*12 +val(split(x,"年")(1))=12*a+b

158807837

grf1973 发表于 2015-11-30 15:15
x=a年b月，总月=val(split(x,"年")(0))*12 +val(split(x,"年")(1))=12*a+b

我已经做好了表格
代码超冗长,看有没得优化下

grf1973

另一个帖子不是已经回复了吗