Option Explicit
Public Sub 年齢別カウント_横()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim maxrow1 As Long 'B列最終行
Dim row1 As Long
Dim row2 As Long
Dim col2 As Long
Dim rgs As String
Dim rgs1 As String
Dim rgs2 As String
Dim idx As Long
Dim bun As String
Set sh1 = Worksheets("状況")
Set sh2 = Worksheets("B表")
sh2.Range("G15:M25").ClearContents '値をクリア
maxrow1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row 'B列最終行
For row1 = 3 To maxrow1 '3行目~最終列まで
If sh1.Rows(row1).Hidden = True Then GoTo NEXT99
bun = sh1.Cells(row1, "U").Value '状況シートのU列分類2を選択
idx = GetBunrui(bun) '分類を取得
If idx < 0 Then
MsgBox ("分類2不正")
sh1.Select
sh1.Cells(row1, "U").Select
Exit Sub
End If
row2 = idx + 15 'B表 分類1毎の行番号
idx = GetAge(sh1.Cells(row1, "E").Value) '年齢を取得
col2 = idx + 8 'B表 年齢毎の列番号
sh2.Cells(row2, col2).Value = sh2.Cells(row2, col2).Value + 1
NEXT99:
Next
For row2 = 15 To 25
rgs = "H" & row2 & ":M" & row2
sh2.Cells(row2, "G").Formula = "=sum(" & rgs & ")"
Next
MsgBox ("完了")
End Sub
Private Function GetBunrui(ByVal bun As String) As Long
Dim buns As Variant
Dim i As Long
buns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K")
For i = 0 To UBound(buns)
If bun = buns(i) Then
GetBunrui = i
Exit Function
End If
Next
GetBunrui = -1
End Function
Private Function GetAge(ByVal vage As Variant) As Long
Dim vals As Variant
Dim i As Long
Dim age As Long
vals = Array(15, 20, 25, 30, 35, 40)
GetAge = UBound(vals)
If IsNumeric(vage) = False Then Exit Function
age = Int(vage)
If age < vals(0) Or age >= vals(UBound(vals)) Then Exit Function
For i = 0 To UBound(vals) - 1
If age >= vals(i) And age < vals(i + 1) Then
GetAge = i
Exit Function
End If
Next
End Function
T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOW5tOm9ouWIpeOCq+OCpuODs+ODiF/mqKooKQogICAgRGltIHNoMSBBcyBXb3Jrc2hlZXQKICAgIERpbSBzaDIgQXMgV29ya3NoZWV0CiAgICBEaW0gbWF4cm93MSBBcyBMb25nICAgICdC5YiX5pyA57WC6KGMCiAgICBEaW0gcm93MSBBcyBMb25nCiAgICBEaW0gcm93MiBBcyBMb25nCiAgICBEaW0gY29sMiBBcyBMb25nCiAgICBEaW0gcmdzIEFzIFN0cmluZwogICAgRGltIHJnczEgQXMgU3RyaW5nCiAgICBEaW0gcmdzMiBBcyBTdHJpbmcKICAgIERpbSBpZHggQXMgTG9uZwogICAgRGltIGJ1biBBcyBTdHJpbmcKICAgIFNldCBzaDEgPSBXb3Jrc2hlZXRzKCLnirbms4EiKQogICAgU2V0IHNoMiA9IFdvcmtzaGVldHMoIkLooagiKQogICAgc2gyLlJhbmdlKCJHMTU6TTI1IikuQ2xlYXJDb250ZW50cyAgICAn5YCk44KS44Kv44Oq44KiCiAgICBtYXhyb3cxID0gc2gxLkNlbGxzKFJvd3MuQ291bnQsICJCIikuRW5kKHhsVXApLlJvdyAgJ0LliJfmnIDntYLooYwKICAgIEZvciByb3cxID0gMyBUbyBtYXhyb3cxICAgICcz6KGM55uu772e5pyA57WC5YiX44G+44GnCiAgICAgICAgSWYgc2gxLlJvd3Mocm93MSkuSGlkZGVuID0gVHJ1ZSBUaGVuIEdvVG8gTkVYVDk5CiAgICAgICAgYnVuID0gc2gxLkNlbGxzKHJvdzEsICJVIikuVmFsdWUgICAgJ+eKtuazgeOCt+ODvOODiOOBrlXliJfliIbpoZ4y44KS6YG45oqeCiAgICAgICAgaWR4ID0gR2V0QnVucnVpKGJ1bikgICAgJ+WIhumhnuOCkuWPluW+lwogICAgICAgIElmIGlkeCA8IDAgVGhlbgogICAgICAgICAgICBNc2dCb3ggKCLliIbpoZ4y5LiN5q2jIikKICAgICAgICAgICAgc2gxLlNlbGVjdAogICAgICAgICAgICBzaDEuQ2VsbHMocm93MSwgIlUiKS5TZWxlY3QKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICByb3cyID0gaWR4ICsgMTUgICAgICAgICAnQuihqCDliIbpoZ4x5q+O44Gu6KGM55Wq5Y+3CiAgICAgICAgaWR4ID0gR2V0QWdlKHNoMS5DZWxscyhyb3cxLCAiRSIpLlZhbHVlKSAgICAn5bm06b2i44KS5Y+W5b6XCiAgICAgICAgY29sMiA9IGlkeCArIDggICAgICAgICAgJ0Looagg5bm06b2i5q+O44Gu5YiX55Wq5Y+3CiAgICAgICAgc2gyLkNlbGxzKHJvdzIsIGNvbDIpLlZhbHVlID0gc2gyLkNlbGxzKHJvdzIsIGNvbDIpLlZhbHVlICsgMQpORVhUOTk6CiAgICBOZXh0CiAgICBGb3Igcm93MiA9IDE1IFRvIDI1CiAgICAgICAgcmdzID0gIkgiICYgcm93MiAmICI6TSIgJiByb3cyCiAgICAgICAgc2gyLkNlbGxzKHJvdzIsICJHIikuRm9ybXVsYSA9ICI9c3VtKCIgJiByZ3MgJiAiKSIKICAgIE5leHQKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKClByaXZhdGUgRnVuY3Rpb24gR2V0QnVucnVpKEJ5VmFsIGJ1biBBcyBTdHJpbmcpIEFzIExvbmcKICAgIERpbSBidW5zIEFzIFZhcmlhbnQKICAgIERpbSBpIEFzIExvbmcKICAgIGJ1bnMgPSBBcnJheSgiQSIsICJCIiwgIkMiLCAiRCIsICJFIiwgIkYiLCAiRyIsICJIIiwgIkkiLCAiSiIsICJLIikKICAgIEZvciBpID0gMCBUbyBVQm91bmQoYnVucykKICAgICAgICBJZiBidW4gPSBidW5zKGkpIFRoZW4KICAgICAgICAgICAgR2V0QnVucnVpID0gaQogICAgICAgICAgICBFeGl0IEZ1bmN0aW9uCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICBHZXRCdW5ydWkgPSAtMQpFbmQgRnVuY3Rpb24KClByaXZhdGUgRnVuY3Rpb24gR2V0QWdlKEJ5VmFsIHZhZ2UgQXMgVmFyaWFudCkgQXMgTG9uZwogICAgRGltIHZhbHMgQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGFnZSBBcyBMb25nCiAgICB2YWxzID0gQXJyYXkoMTUsIDIwLCAyNSwgMzAsIDM1LCA0MCkKICAgIEdldEFnZSA9IFVCb3VuZCh2YWxzKQogICAgSWYgSXNOdW1lcmljKHZhZ2UpID0gRmFsc2UgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICBhZ2UgPSBJbnQodmFnZSkKICAgIElmIGFnZSA8IHZhbHMoMCkgT3IgYWdlID49IHZhbHMoVUJvdW5kKHZhbHMpKSBUaGVuIEV4aXQgRnVuY3Rpb24KICAgIEZvciBpID0gMCBUbyBVQm91bmQodmFscykgLSAxCiAgICAgICAgSWYgYWdlID49IHZhbHMoaSkgQW5kIGFnZSA8IHZhbHMoaSArIDEpIFRoZW4KICAgICAgICAgICAgR2V0QWdlID0gaQogICAgICAgICAgICBFeGl0IEZ1bmN0aW9uCiAgICAgICAgRW5kIElmCiAgICBOZXh0CkVuZCBGdW5jdGlvbgo=