Option Explicit
Sub Compter_Reservations()
Dim a, i As Long, j As Long, nbrejours As Long, AL As Object
Set AL = CreateObject("System.Collections.ArrayList")
a = Sheets(1).Range("a3").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
nbrejours = a(i, 2) - a(i, 1)
For j = 0 To nbrejours - 1
If Not AL.Contains(a(i, 1) + j) Then AL.Add a(i, 1) + j
Next
If Not .exists(a(i, 4)) Then
Set .Item(a(i, 4)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 4)).CompareMode = 1
For j = 0 To nbrejours - 1
.Item(a(i, 4))(a(i, 1) + j) = 1
Next
Else
For j = 0 To nbrejours - 1
.Item(a(i, 4))(a(i, 1) + j) = .Item(a(i, 4))(a(i, 1) + j) + 1
Next
End If
Next
AL.Sort
ReDim a(1 To .Count + 1, 1 To AL.Count + 1)
a(1, 1) = ""
For i = 0 To AL.Count - 1
a(1, i + 2) = AL(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .keys()(i)
For j = 0 To .items()(i).Count - 1
a(i + 2, AL.IndexOf(.items()(i).keys()(j), 0) + 2) = .items()(i).items()(j)
Next
Next
End With
Application.ScreenUpdating = False
'Restitution
With Sheets("Feuil2")
.Cells.Clear
With .Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.FormulaLocal = a
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 36
End With
End With
With .Columns(1)
With .Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 38
End With
End With
.Columns.AutoFit
End With
.Activate
End With
Application.ScreenUpdating = True
End Sub