XL 2010 Nombre en fonction du contenu et du format

Sub GetColorAndCount()

atelier1 = Range("A8").Interior.Color
atelier2 = Range("A12").Interior.Color
atelier3 = Range("A18").Interior.Color

Dim codeMatin, codeApresMidi, codeNuit As String

codeMatin = "m"
codeApresMidi = "am"
codeNuit = "n"

Dim atelier1_m, atelier1_am, atelier1_n, atelier2_m, atelier2_am, atelier2_n, atelier3_m, atelier3_am, atelier3_n As Integer

For Each cell In Range("D8:P25")

If cell.Interior.Color = atelier1 Then

    If cell.Value = codeMatin Then
    atelier1_m = atelier1_m + 1
    End If
   
    If cell.Value = codeApresMidi Then
    atelier1_am = atelier1_am + 1
    End If
    If cell.Value = codeNuit Then
    atelier1_n = atelier1_n + 1
    End If
   
    Range("C28") = atelier1_m
    Range("C29") = atelier1_am
    Range("C30") = atelier1_n
       
End If


If cell.Interior.Color = atelier2 Then
   
    If cell.Value = codeMatin Then
    atelier2_m = atelier2_m + 1
    End If
   
    If cell.Value = codeApresMidi Then
    atelier2_am = atelier2_am + 1
    End If
    If cell.Value = codeNuit Then
    atelier2_n = atelier2_n + 1
    End If
   
    Range("C31") = atelier2_m
    Range("C32") = atelier2_am
    Range("C33") = atelier2_n

End If

If cell.Interior.Color = atelier3 Then
   
    If cell.Value = codeMatin Then
    atelier3_m = atelier3_m + 1
    End If
   
    If cell.Value = codeApresMidi Then
    atelier3_am = atelier3_am + 1
    End If
    If cell.Value = codeNuit Then
    atelier3_n = atelier3_n + 1
    End If
   
    Range("C34") = atelier3_m
    Range("C35") = atelier3_am
    Range("C36") = atelier3_n
    
End If


Next cell

End Sub

Function NbColorText(ByRef Plage As Range, ByRef Couleur As Byte, text As String) As Long
    Dim c As Range
    Dim nb As Long
    nb = 0
    For Each c In Plage
        If c.Interior.ColorIndex = Couleur And c.Value = text Then
            nb = nb + 1
        End If
    Next c
    NbColorText = nb
End Function

Function NbColorAndTextSameAs(ByRef Plage As Range, ByRef Cellule As Range) As Long
    NbColorAndTextSameAs = NbColorText(Plage, Cellule.Interior.ColorIndex, Cellule.Value)
End Function

Sub Calcul()
Dim dest As Range, P As Range, Q As Range, d As Object, c As Range, coul&, c1 As Range
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
    Set dest = .[A27] '1ère cellule de destination, à adapter
    With .[A8].CurrentRegion 'à adapter
        If .Columns.Count < 3 Then Exit Sub
        Set P = .Columns(1).Cells
        Set Q = .Columns(3).Resize(, .Columns.Count - 2)
    End With
End With
dest.Resize(Rows.Count - dest.Row + 1, 3).Clear 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
    If c <> "" Then
        coul = c.Interior.Color
        For Each c1 In Intersect(c.MergeArea.EntireRow, Q)
            If c1.Interior.Color = coul Then d(c1.Value) = d(c1.Value) + 1
        Next c1
        If d.Count Then
            dest = c
            dest.Interior.Color = coul
            dest(1, 2).Resize(d.Count) = Application.Transpose(d.keys)
            dest(1, 2).Resize(d.Count).Interior.Color = coul
            dest(1, 3).Resize(d.Count) = Application.Transpose(d.items)
            Set dest = dest(1 + d.Count)
            d.RemoveAll
        End If
    End If
Next c
End Sub

Sub Calcul()
Dim dest As Range, P As Range, Q As Range, ncol%, d As Object, c As Range, coul&, R As Range, c1 As Range, a(), i&, x, j%
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
    Set dest = .[A27] '1ère cellule de destination, à adapter
    With .[A8].CurrentRegion 'à adapter
        If .Columns.Count < 3 Then Exit Sub
        Set P = .Columns(1).Cells
        Set Q = .Columns(3).Resize(, .Columns.Count - 2)
        ncol = Q.Columns.Count
    End With
End With
dest.Resize(Rows.Count - dest.Row + 1, 3).Clear 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
    If c <> "" Then
        coul = c.Interior.Color
        Set R = Intersect(c.MergeArea.EntireRow, Q)
        For Each c1 In R
            If c1.Interior.Color = coul Then d(c1.Value) = ""
        Next c1
        If d.Count Then
            dest = c
            dest.Resize(d.Count, ncol + 2).Interior.Color = coul
            dest(1, 2).Resize(d.Count) = Application.Transpose(d.keys)
            dest(1, 2).Resize(d.Count).Sort dest(1, 2), xlAscending, Header:=xlNo 'tri
            ReDim a(1 To d.Count, 1 To ncol)
            For i = 1 To d.Count
                x = dest(i, 2)
                For j = 1 To ncol
                    For Each c1 In R.Columns(j).Cells
                        If c1 = x And c1.Interior.Color = coul Then a(i, j) = a(i, j) + 1
            Next c1, j, i
            dest(1, 3).Resize(d.Count, ncol) = a
            Set dest = dest(i)
            d.RemoveAll
        End If
    End If
Next c
End Sub

Sub Calcul()
Dim dest As Range, P As Range, Q As Range, ncol%, d1 As Object, d2 As Object, c As Range, coul&, R As Range, c1 As Range, x$, a(), i&, j%
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
    Set dest = .[A27] '1ère cellule de destination, à adapter
    With .[A8].CurrentRegion 'à adapter
        If .Columns.Count < 3 Then Exit Sub
        Set P = .Columns(1).Cells
        Set Q = .Columns(3).Resize(, .Columns.Count - 2)
        ncol = Q.Columns.Count
    End With
End With
dest.Resize(Rows.Count - dest.Row + 1, 3).Clear 'RAZ
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In P
    If c <> "" Then
        coul = c.Interior.Color
        Set R = Intersect(c.MergeArea.EntireRow, Q)
        For Each c1 In R
            If c1.Interior.Color = coul Then
                d1(c1.Value) = ""
                x = c1 & Chr(1) & c1.Column - 2
                d2(x) = d2(x) + 1
            End If
        Next c1
        If d1.Count Then
            dest = c
            dest.Resize(d1.Count, ncol + 2).Interior.Color = coul
            dest(1, 2).Resize(d1.Count) = Application.Transpose(d1.keys)
            dest(1, 2).Resize(d1.Count).Sort dest(1, 2), xlAscending, Header:=xlNo 'tri
            ReDim a(1 To d1.Count, 1 To ncol)
            For i = 1 To d1.Count
                x = dest(i, 2)
                For j = 1 To ncol
                    a(i, j) = d2(x & Chr(1) & j)
            Next j, i
            dest(1, 3).Resize(d1.Count, ncol) = a
            Set dest = dest(i)
            d1.RemoveAll
            d2.RemoveAll
        End If
    End If
Next c
End Sub