Sub toto()
Dim rdate, x As Long, j As Long, i As Long, Ta, Tb()
rdate = Application.InputBox("Entrez le premier jour du mois (jj/mm/aa)")
On Error Resume Next
If Not IsDate(rdate) Then
MsgBox "Saisie non valide"
Exit Sub
End If
On Error GoTo 0
rdate = CDate(rdate)
x = 1
With Sheets("Liste")
Ta = .Range("A1:A" & .Range("A65000").End(xlUp).Row).Value
For j = 1 To DateSerial(Year(rdate), Month(rdate) + 1, 1) - rdate
For i = 1 To UBound(Ta)
ReDim Preserve Tb(1 To 2, 1 To x)
Tb(1, x) = Ta(i, 1)
Tb(2, x) = DateSerial(Year(rdate), Month(rdate), j)
x = x + 1
Next
Next
End With
With Sheets("Bd")
.Range("A1").Resize(UBound(Tb, 2), UBound(Tb, 1)) = Application.Transpose(Tb)
End With
End Sub