'### A adapter en fonction du nom des feuilles ###
Const LISTE As String = "Liste"
Const PLANNING As String = "Planning"
'#################################################
Sub MakePlanning()
Dim maDate As Date
Dim var
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim C As Range
Dim i&
On Error GoTo Erreur
Set S2 = Sheets(PLANNING)
Do
var = InputBox("Sélectionnez une date")
If var = "" Then Exit Sub
If InStr(1, var, "/") + InStr(1, var, "-") = 0 Then var = ""
Loop Until IsDate(var)
maDate = CDate(var)
Application.ScreenUpdating = False
Sheets(LISTE).Copy before:=Sheets(1)
Set S = ActiveSheet
Set R = S.Range(S.Cells(1, 1), _
S.Cells(S.[a65536].End(xlUp).Row, S.[iv1].End(xlToLeft).Column))
var = R.Value2
For i& = UBound(var, 1) To 1 Step -1
S.Range("b" & i& & "") = i&
If var(i&, 1) <> maDate Then
S.Rows(i&).Delete
End If
Next i&
Application.DisplayAlerts = False
If S.[a1] = "" Then
S.Delete
MsgBox "Aucune donnée trouvée à la date du " & Format(maDate, "dd/mm/yyyy")
Exit Sub
End If
S.Columns(1).Delete
Set R = S.UsedRange
R.Sort Key1:=S.[b1], Order1:=xlAscending, _
Key2:=S.[f1], Order2:=xlAscending, Header:=xlNo
For i& = R.Rows.Count To 2 Step -1
If S.Range("b" & i& & "") <> S.Range("b" & i& - 1 & "") Then
S.Rows(i&).Insert
End If
Next i&
For i& = S2.UsedRange.Rows.Count To 4 Step -1
S2.Rows(i&).Delete
Next i&
S2.[b1] = maDate
S.UsedRange.Copy
S2.Activate
S2.[a4].Select
ActiveSheet.Paste
Set R = S2.Range(S2.Cells(4, 1), S2.Cells(S2.[a65536].End(xlUp).Row, 1))
For Each C In R
If C <> "" Then
ActiveSheet.Hyperlinks.Add Anchor:=C, Address:="", _
SubAddress:=LISTE & "!A" & C, _
ScreenTip:="Retour à " & LISTE
C = LCase(LISTE) & " " & C
End If
Next C
S2.[a1].Select
S.Delete
S2.Select
Erreur:
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub
