Sub Sample()
    Dim wsShift As Worksheet
    Dim cellToCheck As Range
    Dim lastRow As Long, i As Long, k As Long
    Dim RR As Long, Cnt As Long, DyCol As Long
    
    Set wsShift = Worksheets("勤務作成")
    lastRow = wsShift.Cells(Rows.Count, "A").End(xlUp).Row
    
    Set cellToCheck = Worksheets("カレンダー").Range("A3:G32")
    DyCol = 1 '初期値をセット
    
    For i = 1 To 30 Step 5
        cellToCheck(i + 1, 1).Resize(4, 7) = Empty '前回処理の残データをクリア
        
        For k = 1 To 7
        
            If IsNumeric(CStr(cellToCheck(i, k))) Then '日付相当セルなら
                DyCol = DyCol + 1 '日付列順を求める
                Cnt = 0
                
                For RR = 4 To lastRow '全員をチェック
                    If wsShift.Cells(RR, DyCol) = 1 Then
                        Cnt = Cnt + 1
                        
                        '名前を直下セルに転記
                        cellToCheck(i + Cnt, k) = wsShift.Cells(RR, "A")
                    End If
                Next RR
            End If
        Next k
    Next i
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他