Option Explicit
Sub AjoutDate()
Dim maDate As Date, tablo As Range, tbl As Range, cel As Range
Dim i&, k&, col&, fin&, lignes&, lig&, dt As Date, c As Range
Application.ScreenUpdating = False
maDate = InputBox("Veuillez entrer la date du jour.", "Nouveau Tableau")
On Error Resume Next
lignes = Range("a3").End(xlDown).Row
Set tablo = Range("a3:bi" & lignes)
tablo.Copy
Set cel = Range("a" & Rows.Count).End(xlUp)(2)
cel.PasteSpecial xlPasteFormulas
cel.PasteSpecial xlPasteFormats
lig = Range("bk3").End(xlDown).Row
Set tbl = Range("bk3:bp" & lig)
tbl.Copy
Set c = Range("bk" & Rows.Count).End(xlUp)(2)
c.PasteSpecial xlPasteFormulas
c.PasteSpecial xlPasteFormats
Application.CutCopyMode = 0
dt = DateSerial(Year(maDate), Month(maDate), Day(maDate))
fin = Cells(Rows.Count, 4).End(xlUp).Row
For i = cel.Row To cel.Row + 21
If Cells(i, "A") <> "" Then
For k = i To fin
Cells(k, "D") = CDate(dt)
For col = 1 To 61
If Cells(k, col).Interior.Color = vbYellow Then Cells(k, col).ClearContents
Next col
For col = 65 To 68
Cells(k, col).ClearContents
Next col
Next k
End If
Next i
Application.Goto Range("a1")
End Sub