Sub test()
Dim d, arr, i%, brr, k, t
Set d = CreateObject("scripting.dictionary")
arr = Split("行号,地市,30岁以下,30(含30)-50,50(含50)-60,60(含70)-70,70(含70)岁以上,空白未填写,合计", ",")
Sheet1.Activate
la = CDate(WorksheetFunction.Large([p3:p28], 1))
On Error Resume Next
endtime = CDate(InputBox("输入截止日期", "输入日期", Date))
If Err.Number <> 0 Then Exit Sub
If endtime < la Then MsgBox "输入日期小于最年轻的人员的出生年份": Call test
For i = 3 To 28
If IsDate(Cells(i, 16).Value) Then
If Cells(i, 9).Value = "" Then Cells(i, 9).Value = "空白未填写"
d(Cells(i, 9).Value) = IIf(d(Cells(i, 9).Value) = "", DateDiff("yyyy", Cells(i, 16).Value, endtime), _
d(Cells(i, 9).Value) & "," & DateDiff("yyyy", Cells(i, 16).Value, endtime))
Else
d(Cells(i, 9).Value) = d(Cells(i, 9).Value) & "," & "空白未填写"
End If
Next i
k = d.keys
t = d.items
ReDim brr(1 To d.Count + 3, 1 To UBound(arr) + 1)
For i = 1 To UBound(brr, 2)
brr(1, i) = arr(i - 1)
Next i
For i = 3 To UBound(brr) - 1
brr(i, 1) = i - 1: brr(i, 2) = k(i - 3)
For Each c In Split(t(i - 3), ",")
Select Case Val(c)
Case 1 To 29
brr(i, 3) = brr(i, 3) + 1
Case 30 To 49
brr(i, 4) = brr(i, 4) + 1
Case 50 To 59
brr(i, 5) = brr(i, 5) + 1
Case 60 To 69
brr(i, 6) = brr(i, 6) + 1
Case 70 To 120
brr(i, 7) = brr(i, 7) + 1
Case Else
brr(i, 8) = brr(i, 8) + 1
End Select
Next c
Next i
brr(2, 1) = 1: brr(2, 2) = "合计"
For i = 3 To UBound(brr, 2) - 1
For j = 3 To UBound(brr) - 1
brr(j, 9) = brr(j, 9) + brr(j, i)
brr(2, 9) = brr(2, 9) + brr(j, i)
brr(2, i) = brr(2, i) + brr(j, i)
Next j
Next i
brr(UBound(brr), 1) = "注:本表统计截止时间为" & endtime
With Sheet2
.Range("a16").Resize(UBound(brr), UBound(brr, 2))=“”
.Range("a16").Resize(UBound(brr), UBound(brr, 2)) = brr
.Range("a28:d28").Merge
.Range("a28:d28").Font.ColorIndex = 3
End With
End Sub