Tirage sur 52 semaines

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion limat72
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
limat72

limat72

XLDnaute Occasionnel
Bonjour à tous,

voila mon problème..j'aimerais pouvoir faire un tirage d'equipes sur 52 semaines.

il faudrait que les equipes changent toutes les semaines sans que un personnel se retrouvent 2 semaines à la suite.

il faut aussi que l'equipe soit selectionnée en fonction de sa qualification de poste....voir le tableau du personnel
les equipiers 1 et 2 sont selectionnées dans la colonne equipier

merci de votre aide

limat
 

Pièces jointes

Trier par date Trier par votes
Re : Tirage sur 52 semaines

deux bugs se sont glissés dans le code. l'un c'est un PB de copié collé, l'autre c'est un controle de cohérence fait dans le mauvais ordre (qui donc ne marchait pas.)

L'intéret de ce code, est que l'on peut supprimer les fiches des semaines à venir (à la main) et qu'il recalcule ensuite le reste.
Voici le Bon code, il reste ptet des bugs... voir à l'usage

j'aurai pu mettre plus de commentaires....sorry

Code: 
Sub creation_tableau()

'Programme réalisé par ODESTA pour la création d'équipes

Dim tableau_CA(20, 1) '0,0 est le nombre de ligne i,0 le nom i,1 le nombre d'intervention
                      '0,1  la personne de la semaine précédent le remplissage
Dim tableau_CDT(20, 1)
Dim tableau_Equipier(100, 2)


'Création des tableaux en fonction des noms (attention à ne pas dépasser 20 pour CA et CDT et 100 pour Equipier)
ligne = 2
i = 1
While Cells(ligne, 1).Value <> ""
tableau_CA(i, 0) = Cells(ligne, 1).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_CA(0, 0) = ligne - 1 - 1 'pensez à supprimer le ligne titre et la ligne en trop du à la fonction while

ligne = 2
i = 1
While Cells(ligne, 2).Value <> ""
tableau_CDT(i, 0) = Cells(ligne, 2).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_CDT(0, 0) = ligne - 1 - 1

ligne = 2
i = 1
While Cells(ligne, 3).Value <> ""
tableau_Equipier(i, 0) = Cells(ligne, 3).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_Equipier(0, 0) = ligne - 1 - 1


'récupération des lignes déja renseignées
For i = 2 To 54
    ' CA
    If Cells(i, 6).Value <> "" Then
            valeur = Cells(i, 6).Value
            For j = 1 To tableau_CA(0, 0)
                If tableau_CA(j, 0) = valeur Then
                    tableau_CA(j, 1) = tableau_CA(j, 1) + 1
                End If
            Next
    End If
    
        ' CDT
    If Cells(i, 7).Value <> "" Then
            valeur = Cells(i, 7).Value
            For j = 1 To tableau_CDT(0, 0)
                If tableau_CDT(j, 0) = valeur Then
                    tableau_CDT(j, 1) = tableau_CDT(j, 1) + 1
                End If
            Next
    End If
    
        ' Equipier
    If Cells(i, 8).Value <> "" Then
            valeur = Cells(i, 8).Value
            For j = 1 To tableau_Equipier(0, 0)
                If tableau_Equipier(j, 0) = valeur Then
                    tableau_Equipier(j, 1) = tableau_Equipier(j, 1) + 1
                End If
            Next
    End If
    If Cells(i, 9).Value <> "" Then
            valeur = Cells(i, 9).Value
            For j = 1 To tableau_Equipier(0, 0)
                If tableau_Equipier(j, 0) = valeur Then
                    tableau_Equipier(j, 1) = tableau_Equipier(j, 1) + 1
                End If
            Next
    End If
Next


'création des lignes
'récupération de la semaine en cours (pour ne pas avoir de répétition)
ligne = 2
If Cells(2, 6).Value = "" Then
    'si tableau vide
    
Else 'si tableau deja remplis en partie
    While Cells(ligne, 6).Value <> "" And ligne < 55
        
        ligne = ligne + 1
    Wend
    tableau_CA(0, 1) = Cells(ligne - 1, 6).Value
    tableau_CDT(0, 1) = Cells(ligne - 1, 7).Value
    tableau_Equipier(0, 1) = Cells(ligne - 1, 8).Value
    tableau_Equipier(0, 2) = Cells(ligne - 1, 9).Value

End If



For i = 2 To 54
    'CA
    CA_min = 54
    If Cells(i, 6).Value = "" Then
        'récupéré le CA ayant intervenu le moins...
        For j = 1 To tableau_CA(0, 0)
            If tableau_CA(j, 0) <> tableau_CA(0, 1) And tableau_CA(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_CA(j, 1)
                Position = j
            End If
        Next
        Cells(i, 6).Value = tableau_CA(Position, 0)
        tableau_CA(Position, 1) = tableau_CA(Position, 1) + 1
        tableau_CA(0, 1) = tableau_CA(Position, 0)
    End If
    
        'CDT
    CA_min = 54
    If Cells(i, 7).Value = "" Then
        'récupéré le CDT ayant intervenu le moins...
        For j = 1 To tableau_CDT(0, 0)
            If tableau_CDT(j, 0) <> tableau_CDT(0, 1) And tableau_CDT(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_CDT(j, 1)
                Position = j
            End If
        Next
        Cells(i, 7).Value = tableau_CDT(Position, 0)
        tableau_CDT(Position, 1) = tableau_CDT(Position, 1) + 1
        tableau_CDT(0, 1) = tableau_CDT(Position, 0)
    End If
    
        'Equipier 1
    CA_min = 54
    If Cells(i, 8).Value = "" Then
        'récupéré le CDT ayant intervenu le moins...
        For j = 1 To tableau_Equipier(0, 0)
            If tableau_Equipier(j, 0) <> tableau_Equipier(0, 1) And tableau_Equipier(j, 0) <> tableau_Equipier(0, 2) And tableau_Equipier(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_Equipier(j, 1)
                Position = j
            End If
        Next
        Cells(i, 8).Value = tableau_Equipier(Position, 0)
        tableau_Equipier(Position, 1) = tableau_Equipier(Position, 1) + 1
        Equipier1 = tableau_Equipier(0, 1)
        tableau_Equipier(0, 1) = tableau_Equipier(Position, 0)
    End If
    
        'Equipier 2
    CA_min = 54
    If Cells(i, 9).Value = "" Then
        'récupéré le CDT ayant intervenu le moins...
        For j = 1 To tableau_Equipier(0, 0)
            If tableau_Equipier(j, 0) <> Equipier1 And tableau_Equipier(j, 0) <> tableau_Equipier(0, 1) And tableau_Equipier(j, 0) <> tableau_Equipier(0, 2) And tableau_Equipier(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_Equipier(j, 1)
                Position = j
            End If
        Next
        Cells(i, 9).Value = tableau_Equipier(Position, 0)
        tableau_Equipier(Position, 1) = tableau_Equipier(Position, 1) + 1
        tableau_Equipier(0, 2) = tableau_Equipier(Position, 0)
    End If
    
Next


End Sub
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

Ah oui, je comprends...
le choix ce fait par nombre d'intervention, puis par présence dans la semaine précédente.
Au bous d'un moment, lorsqu'il y a équilibre du nombre d'intervention, le programme répète le même shéma : il correspond à la demande.

Il faudrait donc ajouter un paramêtre aléatoire dans le programme, pour choisir entre les personnes ayant le même nombre d'intervention.

Dur...
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

Odesta à dit:
Ah oui, je comprends...
le choix ce fait par nombre d'intervention, puis par présence dans la semaine précédente.
Au bous d'un moment, lorsqu'il y a équilibre du nombre d'intervention, le programme répète le même shéma : il correspond à la demande.

Il faudrait donc ajouter un paramêtre aléatoire dans le programme, pour choisir entre les personnes ayant le même nombre d'intervention.

Dur...
Cliquez pour agrandir...

bonjour Odesta....

j'espère que c'est pas trop compliqué pour modfier ce code
on est si proche du but....
si c'est pas possible dis le moi

a+
limat
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

Hello

J'ai trouvé la solution cette nuit.

Mon code fonctionne de la manière suivante pour trouver QUI mettre :

Il défini un valeur (ici 54, car je suis sur que le nombre d'intervention sera inférieur.
Il prend la première personne de la liste
Il compare 54 au nombre d'intervention de cette personne
Si le nombre d'intervention est < (forcement pour le prmeier test) il baisse ce nombre.
Il prend la deuxième personne, il compare de la même manière. Là, il y a 3 possibilités, a) la personne a moins d'intervention, alors le nombre change (et la personne désigné aussi). b) égalité et c) plus d'intervention : le nombre ne change pas, et la personne non plus. Il effectue ce test pour tout le monde, touvant ainsi la première personne ayant le moins d'intervention à chaque fois.
Cette règle, qui dépend de la liste initiale, nous donne donc un roulement qui n'est pas aléatoire.

La solution :
faire que le cas b) Egalité, soit de temps à autre comme a) et le reste du temps comme c).
L'effet : il arrivera (à un taux qu'il faut définir) que ce soit la personne suivante dans la liste qui soit prise, à condition qu'il y est égalité. Le coté aléatoire, mélangera alors l'ordre prédifini par la liste de nom.



je te propose de modifier le code ? car je n'aurai pas trop le temps d'y travailler.

les étapes : créer un nombre aléatoire (RND), définir un seuil (à priori 0,5), le transofrmer en boolean, et ajouter ce boolean à la condtion
And tableau_Equipier(j, 1) < CA_min
en la transformant en :
And (aiguillage_alea and tableau_Equipier(j, 1) < CA_min) or (not aiguillage_alea and tableau_Equipier(j, 1) <= CA_min)
=> si aiguillage_alea=vrai, c'est b) = c) et si c'est aiguillage_alea=faux c'est b)=a)

Est-ce suffisamment clair ?
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

nouveau code :

Code: 
Sub creation_tableau()

'Programme réalisé par ODESTA pour la création d'équipes

Dim tableau_CA(20, 1) '0,0 est le nombre de ligne i,0 le nom i,1 le nombre d'intervention
                      '0,1  la personne de la semaine précédent le remplissage
Dim tableau_CDT(20, 1)
Dim tableau_Equipier(100, 2)


'Création des tableaux en fonction des noms (attention à ne pas dépasser 20 pour CA et CDT et 100 pour Equipier)
ligne = 2
i = 1
While Cells(ligne, 1).Value <> ""
tableau_CA(i, 0) = Cells(ligne, 1).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_CA(0, 0) = ligne - 1 - 1 'pensez à supprimer le ligne titre et la ligne en trop du à la fonction while

ligne = 2
i = 1
While Cells(ligne, 2).Value <> ""
tableau_CDT(i, 0) = Cells(ligne, 2).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_CDT(0, 0) = ligne - 1 - 1

ligne = 2
i = 1
While Cells(ligne, 3).Value <> ""
tableau_Equipier(i, 0) = Cells(ligne, 3).Value
i = i + 1
ligne = ligne + 1
Wend
tableau_Equipier(0, 0) = ligne - 1 - 1


'récupération des lignes déja renseignées
For i = 2 To 54
    ' CA
    If Cells(i, 6).Value <> "" Then
            valeur = Cells(i, 6).Value
            For j = 1 To tableau_CA(0, 0)
                If tableau_CA(j, 0) = valeur Then
                    tableau_CA(j, 1) = tableau_CA(j, 1) + 1
                End If
            Next
    End If
    
        ' CDT
    If Cells(i, 7).Value <> "" Then
            valeur = Cells(i, 7).Value
            For j = 1 To tableau_CDT(0, 0)
                If tableau_CDT(j, 0) = valeur Then
                    tableau_CDT(j, 1) = tableau_CDT(j, 1) + 1
                End If
            Next
    End If
    
        ' Equipier
    If Cells(i, 8).Value <> "" Then
            valeur = Cells(i, 8).Value
            For j = 1 To tableau_Equipier(0, 0)
                If tableau_Equipier(j, 0) = valeur Then
                    tableau_Equipier(j, 1) = tableau_Equipier(j, 1) + 1
                End If
            Next
    End If
    If Cells(i, 9).Value <> "" Then
            valeur = Cells(i, 9).Value
            For j = 1 To tableau_Equipier(0, 0)
                If tableau_Equipier(j, 0) = valeur Then
                    tableau_Equipier(j, 1) = tableau_Equipier(j, 1) + 1
                End If
            Next
    End If
Next


'création des lignes
'récupération de la semaine en cours (pour ne pas avoir de répétition)
ligne = 2
If Cells(2, 6).Value = "" Then
    'si tableau vide
    
Else 'si tableau deja remplis en partie
    While Cells(ligne, 6).Value <> "" And ligne < 55
        
        ligne = ligne + 1
    Wend
    tableau_CA(0, 1) = Cells(ligne - 1, 6).Value
    tableau_CDT(0, 1) = Cells(ligne - 1, 7).Value
    tableau_Equipier(0, 1) = Cells(ligne - 1, 8).Value
    tableau_Equipier(0, 2) = Cells(ligne - 1, 9).Value

End If



For i = 2 To 54
    'CA
    CA_min = 54
    If Cells(i, 6).Value = "" Then
        'récupéré le CA ayant intervenu le moins...
        For j = 1 To tableau_CA(0, 0)
            If tableau_CA(j, 0) <> tableau_CA(0, 1) And tableau_CA(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_CA(j, 1)
                Position = j
            End If
        Next
        Cells(i, 6).Value = tableau_CA(Position, 0)
        tableau_CA(Position, 1) = tableau_CA(Position, 1) + 1
        tableau_CA(0, 1) = tableau_CA(Position, 0)
    End If
    
        'CDT
    CA_min = 54
    If Cells(i, 7).Value = "" Then
        'récupéré le CDT ayant intervenu le moins...
        For j = 1 To tableau_CDT(0, 0)
            If tableau_CDT(j, 0) <> tableau_CDT(0, 1) And tableau_CDT(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_CDT(j, 1)
                Position = j
            End If
        Next
        Cells(i, 7).Value = tableau_CDT(Position, 0)
        tableau_CDT(Position, 1) = tableau_CDT(Position, 1) + 1
        tableau_CDT(0, 1) = tableau_CDT(Position, 0)
    End If
    
        'Equipier 1
    CA_min = 54
    If Cells(i, 8).Value = "" Then
        'récupérer l'équipier ayant intervenu le moins...
        For j = 1 To tableau_Equipier(0, 0)
            aiguillage_alea = False
            If Rnd < 0.5 Then aiguillage_alea = True
            If tableau_Equipier(j, 0) <> tableau_Equipier(0, 1) And tableau_Equipier(j, 0) <> tableau_Equipier(0, 2) And ((aiguillage_alea And tableau_Equipier(j, 1) < CA_min) Or (Not aiguillage_alea And tableau_Equipier(j, 1) <= CA_min)) Then '...et différent de celui de la semaine précédente
                CA_min = tableau_Equipier(j, 1)
                Position = j
            End If
        Next
        Cells(i, 8).Value = tableau_Equipier(Position, 0)
        tableau_Equipier(Position, 1) = tableau_Equipier(Position, 1) + 1
        Equipier1 = tableau_Equipier(0, 1)
        tableau_Equipier(0, 1) = tableau_Equipier(Position, 0)
    End If
    
        'Equipier 2
    CA_min = 54
    If Cells(i, 9).Value = "" Then
        'récupérer l'équipier ayant intervenu le moins...
        For j = 1 To tableau_Equipier(0, 0)
            If tableau_Equipier(j, 0) <> Equipier1 And tableau_Equipier(j, 0) <> tableau_Equipier(0, 1) And tableau_Equipier(j, 0) <> tableau_Equipier(0, 2) And tableau_Equipier(j, 1) < CA_min Then '...et différent de celui de la semaine précédente
                CA_min = tableau_Equipier(j, 1)
                Position = j
            End If
        Next
        Cells(i, 9).Value = tableau_Equipier(Position, 0)
        tableau_Equipier(Position, 1) = tableau_Equipier(Position, 1) + 1
        tableau_Equipier(0, 2) = tableau_Equipier(Position, 0)
    End If
    
Next


End Sub
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

bonjour à tous,
Bonjour Odesta,

je reviens avec mon fichier de garde....

Je dois rajouter un stationnaire avec l'equipe de garde qui changent bien sur toutes les semaines comme l'equipe...

Comment dois-je modifier le code.

Je joins le fichier avec mes essais par rapport à ton code

Merci de votre aide

Limat
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

Bonjour à tous,

quelqu'un aurais t'il une solution à mon problème....

Le tirage ne doit pas pas mettre le stationnaire qui est déja dans l'équipe de garde.

Certaines fois cela marche mais la plupart du temps le stationnaire est déja dans l'equipe....

merci de votre aide

limat
 
Vote positif 0 Vote négatif
Re : Tirage sur 52 semaines

limat72 à dit:
bonjour à tous,
Bonjour Odesta,

je reviens avec mon fichier de garde....

Je dois rajouter un stationnaire avec l'equipe de garde qui changent bien sur toutes les semaines comme l'equipe...

Comment dois-je modifier le code.

Je joins le fichier avec mes essais par rapport à ton code

Merci de votre aide

Limat
Cliquez pour agrandir...

limat72 à dit:
Bonjour à tous,

quelqu'un aurais t'il une solution à mon problème....

Le tirage ne doit pas pas mettre le stationnaire qui est déja dans l'équipe de garde.

Certaines fois cela marche mais la plupart du temps le stationnaire est déja dans l'equipe....

merci de votre aide

limat
Cliquez pour agrandir...

Bonjour à tous ce matin de bonne humeur.....

je n'ai toujours pas réussi a realiser mon problème de stationnaire...
Un ptit coup de main serait bienvenu
Amicalement

Limat

PS/ faut-il revoir la conception du fichier? le principe doit etre tjrs aléatoire et en fonction dus parametres
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Lu76Fer
XLS : Evènements souris 'click' sur la grille & astuces
Réponses
3
Affichages
413
Lu76Fer
Lu76Fer
O
  • Question Question
XL 2019 Code VBA pour automatiser la programmation des rotations des ouvriers qui travaillent à temps partiel et se relaient par période de temps constante.
2 3
Réponses
35
Affichages
2 K
olivier1984
O
S
  • Question Question
XL 2019 Roulement de 14 personnes sur 6 postes pour 1 mois au même poste
Réponses
1
Affichages
1 K
Setroc
S
C
  • Question Question
Microsoft 365 Macro pour créer boite de dialogue
2
Réponses
21
Affichages
2 K
Dudu2
Dudu2
P
  • Résolu(e)
Microsoft 365 Crée un VBA pour repérer des doublons sur un tableur excel
2 3
Réponses
31
Affichages
4 K
patrick965
P
B
  • Question Question
Microsoft 365 Base de données sur exel
Réponses
9
Affichages
875
bernypiz
B
J
  • Question Question
Microsoft 365 Décaler une date si férié sur un lundi.
Réponses
9
Affichages
897
JHA
J
F
  • Question Question
XL 2019 Calcul de moyenne sur plage variable
Réponses
14
Affichages
1 K
mapomme
mapomme
S
  • Question Question
XL 2016 Remplacer cellule par une autre si cellule vide sur 2 colonnes
Réponses
6
Affichages
861
stephanie94
S
B
  • Question Question
XL 2016 tournoi de foot à 14 et 16 équipes
Réponses
1
Affichages
9 K
Pounet95
P
P
  • Question Question
XL 2013 Modification d'une macro existant
Réponses
3
Affichages
1 K
pimpom69
P
Z
  • Résolu(e)
XL 2016 TRIER DES VENTES PAR SEMAINE
Réponses
2
Affichages
1 K
ZEBULON-68
Z
I
  • Question Question
Tirage aléatoire tournoi chapeaux
2
Réponses
15
Affichages
3 K
frederio
frederio
sebbbbb
  • Question Question
XL 2010 mettre en concordance personnel (selon compétence et dispo) avec planning de taches sur 2 semaines
Réponses
3
Affichages
2 K
sebbbbb
sebbbbb
Y
  • Question Question
XL pour MAC Méthode des J adapté
Réponses
10
Affichages
7 K
YasinGS
Y
sebbbbb
  • Question Question
XL 2010 Faire coïncider 2 bases de données pour trouver le ou les propositions adéquates
Réponses
0
Affichages
798
sebbbbb
sebbbbb
M
  • Question Question
XL 2013 Somme par semaine
Réponses
5
Affichages
4 K
Mercenr
M
W
  • Question Question
XL 2019 Historique de cellules sur 3 colonnes
Réponses
0
Affichages
408
willaucl23
W
D
  • Question Question
XL 2016 top 3 par semaine
Réponses
2
Affichages
552
Dombal
D
sebbbbb
  • Question Question
XL 2010 Création de menus déroulants conditionnels en fonction de 3 paramètres situés dans 3 onglets différents
Réponses
8
Affichages
1 K
sebbbbb
sebbbbb
Retour