XL 2010 Nombre en fonction du contenu et du format

[dn35]

Bonjour le forum !

Petit problème à vous soumettre !
On m'a demandé de créer un outil de planification assez complexe. Seulement voilà, sans vba .... ça ne va pas ! Et là forcément je coince. Pour le moment j'en suis à récupérer les informations de personnel au sein de plusieurs ateliers. L'idée c'est de connaître le nombre de personnes affectées pour chaque poste dans chaque atelier afin d'une part de s'assurer qu'il n'y a pas de doublons ou de poste non pouvu et de connaître l'effectif afin de dispacher les tâches en fonction de cet effectif.
En clair je souhaiterais "compter" le nombre de poste ("m" / "am" / "n") pour chaque jour et pour chaque atelier sachant que la répartition dans les ateliers répond à un code couleur.
En faisant des recherches dans le forum, j'ai bien trouvé des fils sur le même thème mais je ne réussi pas à l'appliquer à mon cas. Le plus proche est celui-ci https://www.excel-downloads.com/threads/somme-si-couleur.20021534/#post-20159035 mais malheureusement le système de copier/coller ne peut pas s'appliquer à mon cas. il me faut quelque chose de plus automatique.

Des idées ?
Ci-joint petit fichier pour mieux illustrer mon problème.
Merci !!!

 

[dn35]

Petite correction, sur le fichier joint il y a le message suivant en C28 :
'= nombre si "m" et si couleur de la cellule est la même qu'en A1

Il s'agit de la couleur de A28 et non A1 ....

 

[Johan]

Salut,

Une solution simple serait de récupérer le code couleur des 3 ateliers et balayer chaque cellule du planning en fonction du roulement matin / aprem / nuit.

A voir si cela convient :

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

Johan

 

[fanfan38]

Bonjour,
C'est quoi cop
J'ai 30ans de 3x8 et crois moi 5 nuits c'est raide...
Y a t'il un roulement?
travaille t'il le we
combien faut il de personnes de m,am et n?
A+ François

 

[dn35]

Hello,

Merci de votre retour,
@Johan , merci je vais regarder ton code. En continuant mes recherches sur d'autres forum, je suis tombée là-dessus aussi mais je doit encore tester :

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

Donc je vois ça et je reviens avec le résultat.

@fanfan38 oui c'est raide ! Notre fonctionnement est carrément m***ique mais malgré plusieurs propositions, les gars veulent rester en 3*8 sur les 7 jours de la semaine ce qui fait que le planning est une usine à Gaz.
Pour l'atelier 1 il faut entre 1 et 3 personnes du lundi au vendredi
Pour les ateliers 2 et 3 il faut 2 personnes sur les 7 jours de la semaine.
Le roulement souhaité par les équipes est n/am/m

Merci !

 

[fanfan38]

Bonjour
Ci joint ma solution
A+ François

 

[dn35]

Merci @fanfan38 ! Ça semble fonctionner très bien, c'est très intéressant ! Et je pense que ça va me servir pour d'autres aspects de mon fichier final également.

De mon côté j'ai avancé avec ce que j'avais trouvé, ce ça fonctionne également. Ci-joint mon fichier, ça peut servir à d'autres !

Un grand merci encore

 

[job75]

Bonjour dn35, johan, fanfan38,

Je comprends qu'il faut compter les occurrences de la même couleur que la cellule fusionnée en A :

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

Fichier joint.

A+

 

[dn35]

Bonjour @job75 et merci.
Effectivement il faut compter le nombre d’occurrences de la même couleur et du même code horaire mais à la journée, sinon ça ne serait pas drôle !
Mais comme le fichier de fanfan, ton code m'intéresse car vu l'ampleur que risque de prendre le fichier (et au passage de devenir un monstre ingérable mais les demandes pleuvent !) je n'ai pas fini de m'aventurer dans le vba.
J'ai peut-être trouvé mon bonheur (voir mon post juste avant le tien) mais je dois affiner dans le fichier final. Donc je m'y atèle demain et je garde précieusement le tiens sous le coude !

Un grand merci
Bonne fin de journée

 

[job75]

Bonjour dn35, le forum,

Effectivement il faut compter le nombre d’occurrences de la même couleur et du même code horaire mais à la journée, sinon ça ne serait pas drôle !

Alors voyez cette nouvelle macro :

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

Fichier (2).

A+

 

[job75]

Re,

Je n'avais pas traité correctement les "FER", j'ai corrigé les macros des posts #8 et #10.

A+

 

[job75]

Re,

Avec 2 Dictionary ce sera plus rapide :

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

Fichier (3).

A+