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("G6:M9").ClearContents    '値をクリア
    maxrow1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row  'B列最終行
    For row1 = 5 To maxrow1    '8行目～最終列まで
        bun = sh1.Cells(row1, "C").Value    '状況シートのC列分類１を選択
        idx = GetBunrui(bun)    '分類を取得
        If idx < 0 Then
            MsgBox ("分類1不正")
            sh1.Select
            sh1.Cells(row1, "C").Select
            Exit Sub
        End If
        row2 = idx + 6          'B表 分類1毎の行番号
        idx = GetAge(sh1.Cells(row1, "E").Value)    '年齢を取得
        col2 = idx + 8          'B表 年齢毎の列番号
        sh2.Cells(row2, col2).Value = sh2.Cells(row2, col2).Value + 1
    Next
    For row2 = 6 To 9
        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")
    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/mqKooKQogICAgRGltIHNoMSBBcyBXb3Jrc2hlZXQKICAgIERpbSBzaDIgQXMgV29ya3NoZWV0CiAgICBEaW0gbWF4cm93MSBBcyBMb25nICAgICdC5YiX5pyA57WC6KGMCiAgICBEaW0gcm93MSBBcyBMb25nCiAgICBEaW0gcm93MiBBcyBMb25nCiAgICBEaW0gY29sMiBBcyBMb25nCiAgICBEaW0gcmdzIEFzIFN0cmluZwogICAgRGltIHJnczEgQXMgU3RyaW5nCiAgICBEaW0gcmdzMiBBcyBTdHJpbmcKICAgIERpbSBpZHggQXMgTG9uZwogICAgRGltIGJ1biBBcyBTdHJpbmcKICAgIFNldCBzaDEgPSBXb3Jrc2hlZXRzKCLnirbms4EiKQogICAgU2V0IHNoMiA9IFdvcmtzaGVldHMoIkLooagiKQogICAgc2gyLlJhbmdlKCJHNjpNOSIpLkNsZWFyQ29udGVudHMgICAgJ+WApOOCkuOCr+ODquOCogogICAgbWF4cm93MSA9IHNoMS5DZWxscyhSb3dzLkNvdW50LCAiQiIpLkVuZCh4bFVwKS5Sb3cgICdC5YiX5pyA57WC6KGMCiAgICBGb3Igcm93MSA9IDUgVG8gbWF4cm93MSAgICAnOOihjOebru+9nuacgOe1guWIl+OBvuOBpwogICAgICAgIGJ1biA9IHNoMS5DZWxscyhyb3cxLCAiQyIpLlZhbHVlICAgICfnirbms4Hjgrfjg7zjg4jjga5D5YiX5YiG6aGe77yR44KS6YG45oqeCiAgICAgICAgaWR4ID0gR2V0QnVucnVpKGJ1bikgICAgJ+WIhumhnuOCkuWPluW+lwogICAgICAgIElmIGlkeCA8IDAgVGhlbgogICAgICAgICAgICBNc2dCb3ggKCLliIbpoZ4x5LiN5q2jIikKICAgICAgICAgICAgc2gxLlNlbGVjdAogICAgICAgICAgICBzaDEuQ2VsbHMocm93MSwgIkMiKS5TZWxlY3QKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICByb3cyID0gaWR4ICsgNiAgICAgICAgICAnQuihqCDliIbpoZ4x5q+O44Gu6KGM55Wq5Y+3CiAgICAgICAgaWR4ID0gR2V0QWdlKHNoMS5DZWxscyhyb3cxLCAiRSIpLlZhbHVlKSAgICAn5bm06b2i44KS5Y+W5b6XCiAgICAgICAgY29sMiA9IGlkeCArIDggICAgICAgICAgJ0Looagg5bm06b2i5q+O44Gu5YiX55Wq5Y+3CiAgICAgICAgc2gyLkNlbGxzKHJvdzIsIGNvbDIpLlZhbHVlID0gc2gyLkNlbGxzKHJvdzIsIGNvbDIpLlZhbHVlICsgMQogICAgTmV4dAogICAgRm9yIHJvdzIgPSA2IFRvIDkKICAgICAgICByZ3MgPSAiSCIgJiByb3cyICYgIjpNIiAmIHJvdzIKICAgICAgICBzaDIuQ2VsbHMocm93MiwgIkciKS5Gb3JtdWxhID0gIj1zdW0oIiAmIHJncyAmICIpIgogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1YgoKUHJpdmF0ZSBGdW5jdGlvbiBHZXRCdW5ydWkoQnlWYWwgYnVuIEFzIFN0cmluZykgQXMgTG9uZwogICAgRGltIGJ1bnMgQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgYnVucyA9IEFycmF5KCJBIiwgIkIiLCAiQyIsICJEIikKICAgIEZvciBpID0gMCBUbyBVQm91bmQoYnVucykKICAgICAgICBJZiBidW4gPSBidW5zKGkpIFRoZW4KICAgICAgICAgICAgR2V0QnVucnVpID0gaQogICAgICAgICAgICBFeGl0IEZ1bmN0aW9uCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICBHZXRCdW5ydWkgPSAtMQpFbmQgRnVuY3Rpb24KClByaXZhdGUgRnVuY3Rpb24gR2V0QWdlKEJ5VmFsIHZhZ2UgQXMgVmFyaWFudCkgQXMgTG9uZwogICAgRGltIHZhbHMgQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGFnZSBBcyBMb25nCiAgICB2YWxzID0gQXJyYXkoMTUsIDIwLCAyNSwgMzAsIDM1LCA0MCkKICAgIEdldEFnZSA9IFVCb3VuZCh2YWxzKQogICAgSWYgSXNOdW1lcmljKHZhZ2UpID0gRmFsc2UgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICBhZ2UgPSBJbnQodmFnZSkKICAgIElmIGFnZSA8IHZhbHMoMCkgT3IgYWdlID49IHZhbHMoVUJvdW5kKHZhbHMpKSBUaGVuIEV4aXQgRnVuY3Rpb24KICAgIEZvciBpID0gMCBUbyBVQm91bmQodmFscykgLSAxCiAgICAgICAgSWYgYWdlID49IHZhbHMoaSkgQW5kIGFnZSA8IHZhbHMoaSArIDEpIFRoZW4KICAgICAgICAgICAgR2V0QWdlID0gaQogICAgICAgICAgICBFeGl0IEZ1bmN0aW9uCiAgICAgICAgRW5kIElmCiAgICBOZXh0CkVuZCBGdW5jdGlvbgo=