VBA 種類別に自動振り分けをしたい

Question

従業員データを参照し、別シートに年齢ごと性別に振り分け、
更に職種を各セルに抽出したいのですが、
検索をしてもなかなかヒットせず、みなさまにお力添えを頂ければと思い質問します。

成果物
下記のシートより「年齢」「職種」「性別」を参照し、

下記シートにそれぞれの条件ごとセルに「職種」を振り分けしたいです。

イメージは下記のとおりとなります。

各年齢性別ごとに最大２１人の想定としています。

参考になるページだけでも構いませんので、
どうかご教授お願いいたします。

Comments

[UFOnian]

https://teratail.com/help/avoid-asking
https://teratail.com/help/question-tips

Answer 1

シート名が「職員」と「振り分け」として

Public Sub sample()
    Dim data
    data = Worksheets("職員").Range("A1").CurrentRegion.Value

    Dim tbl(19 To 64, -1 To 0)
    Dim i As Long
    For i = 2 To UBound(data)
        Dim sex As Long: sex = (data(i, 4) = "男性")
        tbl(data(i, 6), sex) = tbl(data(i, 6), sex) & "," & Left(data(i, 2), 1)
    Next

    With Worksheets("振り分け")
        For i = 5 To 50
            Dim ary, s As String
            s = Mid(tbl(.Cells(i, "V"), -1), 2)
            If s <> "" Then
                ary = Split(StrReverse(s), ",")
                .Cells(i, "U").Offset(, -UBound(ary)).Resize(, UBound(ary) + 1).Value = ary
            End If
            s = Mid(tbl(.Cells(i, "V"), 0), 2)
            If s <> "" Then
                ary = Split(s, ",")
                .Cells(i, "W").Resize(, UBound(ary) + 1).Value = ary
            End If
        Next
    End With
End Sub

Answer 2

振り分け後の職種がまとまってなくていいのであればこんな感じでしょうか

Sub test()

    Dim i As Long, j As Long, k As Long
    Dim rng As Range, tempRng As Range
        
    j = 21
    k = 23
        
    For i = 19 To 64

        Set rng = Range("F:F").Find(What:=i)
        
        If Not rng Is Nothing Then
            
            Set tempRng = rng
    
            Do
                If Cells(rng.Row, "D").Value = "男性" Then
        
                    Sheets("別シート").Cells(69 - i, j) = Left(Cells(rng.Row, "B").Value, 1)
                    j = j - 1
                    
                ElseIf Cells(rng.Row, "D").Value = "女性" Then
                
                    Sheets("別シート").Cells(69 - i, k) = Left(Cells(rng.Row, "B").Value, 1)
                    k = k + 1
                    
                End If
                
                Set rng = Range("F:F").FindNext(rng)
        
                If rng.Address = tempRng.Address Then
                    Exit Do
                End If
            Loop
        End If
        
        j = 21
        k = 23
    Next
    
End Sub