Sub compter()
Dim der, i&, j&, n, coul&
Application.ScreenUpdating = False
Range("g2:h" & Rows.Count).Clear
der = Application.Max(Application.IfError(Application.Match(9 ^ 99, Columns("d:d")), 0), Application.IfError(Application.Match(String(255, "z"), Columns("d:d")), 0))
i = Application.Max(Application.IfError(Application.Match(9 ^ 99, Columns("e:e")), 0), Application.IfError(Application.Match(String(255, "z"), Columns("e:e")), 0))
If i > der Then der = i
For i = 2 To der
For j = 0 To 1
coul = Cells(i, 4 + j).DisplayFormat.Interior.Color
On Error Resume Next
n = Application.Match(coul, Columns("g:g"), 0)
On Error GoTo 0
If IsError(n) Then
n = Application.Max(Application.IfError(Application.Match(9 ^ 99, Columns("g:g")), 0), Application.IfError(Application.Match(String(255, "z"), Columns("g:g")), 0))
Cells(n + 1, "g") = coul
Cells(n + 1, "g").Interior.Color = coul
Cells(n + 1, "h") = Cells(n + 1, "h") + 1
Else
Cells(n, "h") = Cells(n, "h") + 1
End If
Next j
Next i
Range("g2").CurrentRegion.Borders.LineStyle = xlContinuous
Range("g2:g" & Rows.Count).ClearContents
End Sub