Sub aa()
Dim FC As FormatCondition
Dim S As Worksheet
Dim R As Range
Dim C As Range
Dim T()
Dim tempo
Dim i&
Dim bool As Boolean
'---
Set S = Sheets("Reunions")
S.Select
Set R = S.UsedRange
For Each C In R
If Not IsError(C) Then
For Each FC In C.FormatConditions
If FC.Type = xlCellValue Then
If C = Application.Evaluate(FC.Formula1) Then
On Error Resume Next
tempo = UBound(T)
Err.Clear
On Error GoTo 0
If IsEmpty(tempo) Then
ReDim Preserve T(1 To 2, 1 To 1)
T(1, 1) = T(1, 1) + 1
T(2, 1) = FC.Interior.Color
Else
bool = False
For i& = 1 To UBound(T, 2)
If T(2, i&) = FC.Interior.Color Then
T(1, i&) = T(1, i&) + 1
bool = True
Exit For
End If
Next i&
If Not bool Then
ReDim Preserve T(1 To 2, 1 To UBound(T, 2) + 1)
T(1, UBound(T, 2)) = 1
T(2, UBound(T, 2)) = FC.Interior.Color
End If
End If
End If
End If
Next FC
End If
Next C
'--- Résultats dans une nouvelle feuille ---
Set S = Sheets.Add
For i& = 1 To UBound(T, 2)
Set C = S.Cells(i&, 1)
C = T(1, i&)
C.Interior.Color = T(2, i&)
Next i&
End Sub