こんな感じかな？

Sub test2()
    Dim BottomA As Range
    Dim ans, ret()
    Dim rName As Range, rData As Range, rdates As Range
    Dim dys As Long, i As Long, k As Long
    Dim fDay As Date
    
    ans = InputBox("例：2024/05", "年月を入力してください", Format(Date, "yyyy/mm"))
    If Not ans Like "####/##" Then
        Exit Sub
    Else
        fDay = DateSerial(Year(ans), Month(ans), 0)
        dys = Day(DateSerial(Year(ans), Month(ans) + 1, 0))
    End If
    
    Set BottomA = Cells(Rows.Count, "A").End(xlUp)
    Set rName = Range("A1", BottomA)
    Set rData = Range("B1", BottomA.Offset(, dys))
    
    ReDim ret(1 To BottomA.Row, 1 To dys * 3)
    
    For i = 1 To dys
        For k = 1 To BottomA.Row
            ret(k, i * 3 - 2) = rName(k, 1) '氏名
            ret(k, i * 3 - 1) = IIf(k = 1, "日付", fDay + i) '日付
            ret(k, i * 3) = rData(k, i)  'データ
        Next k
    Next i
     
    Range("A1").Resize(UBound(ret), UBound(ret, 2)) = ret
    
    Set rdates = Range("B2").Resize(BottomA.Row)
    
    For i = 2 To dys
        Set rdates = Union(rdates, Cells(2, i * 3 - 1).Resize(BottomA.Row - 1))
    Next i
    
    rdates.NumberFormat = "m/d"
    Columns("A").Resize(, UBound(ret, 2)).EntireColumn.AutoFit
End Sub


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

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