'### Constante du nom de la feuille source - A adapter ###
Const SOURCE As String = "Perso"
'#########################################################
Sub PlanningDisponibilite()
Dim S As Worksheet
Dim R As Range
Dim T()
Dim Heure()
Dim var
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim nbNom&
Dim nbLig&
Dim jour&
Dim JOURS
Dim switch As Boolean
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S = Sheets(SOURCE)
Set R = S.Range(S.Cells(12, 1), S.Cells(S.[c65536].End(xlUp).Row, 33))
var = R
nbNom& = UBound(var, 1)
Set S = Worksheets.Add(after:=Sheets(Sheets.Count))
JOURS = Array("", "Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche")
ReDim T(1 To (nbNom& + 1) * 7, 1 To 97)
For jour& = 1 To 7
cpt& = cpt& + 1
T(cpt&, 1) = JOURS(jour&)
For i& = 1 To nbNom&
cpt& = cpt& + 1
T(cpt&, 1) = var(i&, 3)
k& = 0
For j& = 6 + (4 * (jour& - 1)) To 6 + (4 * (jour& - 1)) + 3
If IsNumeric(var(i&, j&)) And var(i&, j&) <> "" Then
k& = k& + 1
ReDim Preserve Heure(1 To k&)
Heure(k&) = 24 * var(i&, j&)
If Heure(k&) < 5 Then Heure(k&) = Heure(k&) + 24
Heure(k&) = ((Heure(k&) * 4) - 2) - 16
If k& = 2 Then
If Heure(2) < Heure(1) Then
Set R = S.Range(S.Cells(cpt& + 1, Heure(1)), S.Cells(cpt& + 1, 97))
If Heure(2) > 2 Then
S.Range(S.Cells(cpt& + 1, 2), S.Cells(cpt& + 1, Heure(2) - 1)).Interior.ColorIndex = 3
End If
Else
Set R = S.Range(S.Cells(cpt& + 1, Heure(1)), S.Cells(cpt& + 1, Heure(2) - 1))
End If
If Not switch Then
R.Interior.ColorIndex = 38
Else
R.Interior.ColorIndex = 37
End If
k& = 0
Erase Heure
End If
End If
Next j&
switch = Not switch
Next i&
Next jour&
S.Range(S.Cells(2, 1), S.Cells(UBound(T, 1) + 1, 97)) = T
S.Columns("b:cs").ColumnWidth = 1
ReDim T(1 To 1, 1 To 96)
j& = 5
For i& = 1 To 96 Step 4
If j& > 23 Then j& = 0
T(1, i&) = j& & ":"
j& = j& + 1
Next i&
S.Range(S.Cells(1, 2), S.Cells(1, 97)) = T
For i& = 2 To 97 Step 4
Set R = S.Range(Cells(1, i&), S.Cells(1, i& + 3))
R.NumberFormat = "hh:mm"
R.MergeCells = True
R.HorizontalAlignment = xlLeft
Next i&
Set R = Nothing
nbLig& = S.UsedRange.Rows.Count
For i& = 2 To nbLig& Step nbNom& + 1
If R Is Nothing Then
Set R = S.Range("a2")
Else
Set R = Application.Union(R, S.Range("a" & i& & ""))
End If
Next i&
R.HorizontalAlignment = xlCenter
R.Interior.ColorIndex = 6
R.Font.Bold = True
For i& = 2 To 97 Step 4
Set R = S.Range(S.Cells(1, i&), S.Cells(nbLig&, i& + 3))
For j& = 7 To 10
With R.Borders(j&)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Next j&
Next i&
With ActiveWindow
.SplitRow = 1
.FreezePanes = True
End With
S.[a1].Select
Exit Sub
Erreur:
Application.ScreenUpdating = True
If Err = 9 Then
MsgBox "La feuille ''" & SOURCE & "'' est introuvable."
Else
MsgBox "Erreur :" & Err.Number & vbCrLf & Err.Description
End If
End Sub