répartition sous VBA

[judu]

bonjour

j'aimerais mettre en place un fichier pour mon boulot

j'arrive à générer des listes d'ouvriers et à calculer mes besoins mais j'aimerais répartir les gens aléatoirement sur les postes, tout en gardant en vue le critère "formation" et évidement sans doublon dans le choix de noms... (difficile de séparer un ouvrier en 2, rare sont ceux qui acceptent...)

je met en PJ un fichier pour illustrer ce que j’essaie de faire:

feuille 1, nous avons les postes possibles et les gens formés pour chaque poste
feuille 2, le nombre d'ouvriers nécessaires sur chacun des postes
enfin sur la feuille 3, la répartition aléatoire de personnes sur les postes

j'aimerais de l'aide pour une macro qui choisi dans la feuille 1, le nombre de personnes indiqués pour chaque poste dans la feuille 2 et créée la liste de la feuille 3, toujours sans doublons évidemment...

pensez vous pouvoir m'aider?

merci d'avance

 

[job75]

Bonjour judu,

Pas besoin de VBA.

Voyez le fichier joint et les formules en 1ère et 3ème feuille.

Le fichier est en calcul manuel, touche F9 pour recalculer les formules et obtenir un nouveau tirage.

A+

 

[judu]

heyyy cool
merci, je me suis surement pris la tête pour rien...

par contre est il possible d'interdire les doublons dans ta solution,
je m'explique:
si l'ouvrier 1 est formé au poste A B et C, la formule ne risque elle pas de le sélectionner plusieurs fois?

merci encore et désolé de poser une question de plus

 

[job75]

Re,

Oui, dans ce cas il y aura des doublons dans la 3ème feuille.

A+

 

[job75]

Re,

Une solution VBA pour obtenir un tirage sans doublon dans la 3ème feuille :

Sub Tirage_sans_doublon()
Dim Ntirage&, tirage&
Ntirage = 10000 'limite modifiable
Application.ScreenUpdating = False
Feuil3.[A1].CurrentRegion.Name = "Maplage" 'plage nommée
ThisWorkbook.Names.Add "N", Application.CountIf([MaPlage], "?*") + Sgn(Application.CountBlank([MaPlage])) 'nom défini
For tirage = 1 To Ntirage
  Calculate
  If [SUM(1/COUNTIF(MaPlage,MaPlage))=N] Then Exit Sub
Next
MsgBox "Aucun tirage sans doublon..."
End Sub

Fichier joint avec les mêmes caractéristiques que le fichier du post #2.

A+

 

[job75]

Bonjour judu, le forum,

Fichier (2) avec une MFC pour visualiser les doublons.

S'il y a suffisamment de tirages possibles sans doublon on peut se passer du bouton/VBA.

Bonne journée.

 

[youky(BJ)]

Bonjour Judu, bonjour Job75,
Le sujet m'a plu, j'ai tenté le défit.
Voici avec un bouton et macro
J'utilise le codename pour le nom des onglets a vérifier si autre fichier.
Bruno
Nouveau fichier pour eviter bug si pas de solution
code

Sub poste()
Randomize
Feuil3.[A2:D50].ClearContents
lig = 1
For k = 2 To 11 Step 3
col = col + 1: lg = 1
bas = Feuil1.Cells(500, col).End(3).Row
For b = 1 To Feuil2.Cells(k, 2) 'nbre personnes
Do
num = Int(((bas - 1) * Rnd) + 2)
If Not IsNumeric(Application.Match(Feuil1.Cells(num, col), Feuil3.[J1:J100], 0)) Then
lg = lg + 1: Feuil3.Cells(lg, col) = Feuil1.Cells(num, col)
lig = lig + 1: Feuil3.Cells(lig, 10) = Feuil1.Cells(num, col): i = 0: Exit Do
End If
i = i + 1: If i > 100 Then MsgBox "Recommencez !": Exit Do
Loop
Next
Next
Feuil3.[J1:J100].ClearContents
End Sub

 

[judu]

c'est cooool merci a vous deux,
j'ai une dernière question cependant,
pourriez vous m'expliquer un peu vos fonction. en effet, je ne comprends pas le raisonnement et les fonctions utilisées,
difficile donc de les adapter a mon cas....

 

[job75]

Re, salut Bruno,

difficile donc de les adapter a mon cas....

Pour ce qui me concerne la solution que j'ai donnée n'utilise que des formules assez basiques, et même la macro utilise une formule classique pour compter les valeurs uniques.

A+

 

[youky(BJ)]

Re à tous,
Je viens de commenter mon code.
Il est facile de mettre le curseur sur un mot clef et presser [F1] pour avoir des renseignements
Voir le codename des onglets dans la fenêtre des projets Feuil3 ou Feuil2 ou Feuil1
Feuil3 est répartition Feuil1 est ressource...
Voici le code commenté
Bruno

Sub poste()
Randomize'utilise le time pour générer les chiffres aléatoires
Feuil3.[A2:D50].ClearContents'on efface ancienne données
lig = 1
For k = 2 To 11 Step 3'boucle compte de 3 en 3 de 2 à 11
col = col + 1: lg = 1
bas = Feuil1.Cells(500, col).End(3).Row'dernière cellule, col est N° colonne
For b = 1 To Feuil2.Cells(k, 2) 'nbre personnes
Do' boucle jusqu'a Loop tant que l'on ne fait pas sortir
num = Int(((bas - 1) * Rnd) + 2)'tirage aléatoire bas=bas de la colonne
'appli.match renvoie le N° ligne si trouvé sinon error
If Not IsNumeric(Application.Match(Feuil1.Cells(num, col), Feuil3.[J1:J100], 0)) Then
lg = lg + 1: Feuil3.Cells(lg, col) = Feuil1.Cells(num, col)'mets le nom
'ci-dessous mets le nom à la suite en col J et sort du do-loop
lig = lig + 1: Feuil3.Cells(lig, 10) = Feuil1.Cells(num, col): i = 0: Exit Do
End If
'on incrémente i et si on test 100 fois c'est pas possible on quitte
i = i + 1: If i > 100 Then MsgBox "Recommencez !": Exit Do'ou Exit Sub
Loop
Next'le next de For b
Next'le next de For k
Feuil3.[J1:J100].ClearContents'efface en J
End Sub

 

[judu]

bonjour
merci de vos réponses
cependant le défi est plus compliqué qu'il n'y parait,
les deux solution me sorte des doublons une fois adaptées... je n'arrive pas a m'en débarrasser...
avez vous une idée?
ne peut on pas dans la macro, ajouter une suppression des doublons et remplacement par un autre tirage?

 

[youky(BJ)]

hello Judu,
La macro ne fait pas de doublon.
Test dans ce fichier
Bruno

 

[judu]

en effet, cela fonctionne...
lorsque j'adapte a mon cas, j'obtiens ceci:

Sub repartauto()
Randomize
Feuil2.[A2:J1000].ClearContents
lig = 1
For k = 6 To 30 Step 3
col = col + 1: lg = 1
bas = Feuil4.Cells(500, col).End(3).Row
For b = 1 To Feuil1.Cells(k, 10)
Do
num = Int(((bas - 1) * Rnd) + 2)

If Not IsNumeric(Application.Match(Feuil4.Cells(num, col), Feuil2.[L1:L1000], 0)) Then
lg = lg + 1: Feuil2.Cells(lg, col) = Feuil4.Cells(num, col)

lig = lig + 1: Feuil2.Cells(lig, 10) = Feuil4.Cells(num, col): i = 0: Exit Do
End If

i = i + 1: If i > 1000 Then MsgBox "Recommencez !": Exit Do
Loop
Next
Next
Feuil2.[L1:L1000].ClearContents
End Sub

et j'ai des doublons de partout....

 

[Jauster]

Hello,

Pour rendre le code plus lisible, merci de l’insérer avec le bon bbcode

Insérer > Code > Langue : VB > C/C votre code en dessous

 

[job75]

Bonjour judu, Bruno, Jauster,

cependant le défi est plus compliqué qu'il n'y parait,
les deux solution me sorte des doublons une fois adaptées... je n'arrive pas a m'en débarrasser...

J'ai bien l'impression que vous n'avez pas compris grand-chose à la solution que j'ai proposée.

Je me demande même si vous l'avez testée !

Les formules sont pourtant simples, presqu'évidentes.

A+