Sub dblCommun()
Dim datas, result, dat As Date, dict, nbNom As Long
Dim lig1 As Long, col2 As Long, col As Long, cpt As Long, k
datas = [A2:I2].Resize(Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim result(1 To 3, 1 To UBound(datas))
For lig1 = 1 To UBound(datas)
nbNom = nbNom + 1
If datas(lig1, 1) <> dat Then
If lig1 <> 1 Then
col2 = col2 + 1
result(3, col2) = nbNom - 1
nbNom = 1
For Each k In dict.keys
If dict(k) <> cpt Then dict.Remove k
Next k
result(1, col2) = dat
result(2, col2) = dict.Count
End If
Set dict = Nothing
Set dict = CreateObject("Scripting.Dictionary")
dat = datas(lig1, 1)
cpt = 0
End If
cpt = cpt + 1
For col = 3 To 8
If datas(lig1, col) <> "" Then
If dict.exists(datas(lig1, col)) Then
dict(datas(lig1, col)) = dict(datas(lig1, col)) + 1
Else
dict(datas(lig1, col)) = 1
End If
End If
Next col
Next lig1
Set dict = Nothing
ReDim Preserve result(1 To 3, 1 To col2)
[M1].CurrentRegion.Offset(, 1).ClearContents
[N1:N3].Resize(3, UBound(result)) = result
End Sub