XL 2010 VBA comment faire une distribution aleatoire sous plusieurs conditions??

J

julie211

XLDnaute Nouveau
Bonjour,

J'ai des données ( environs 1000) en manipulant par tableau excel pour faire une distribution aléatoire sans doublons sous plusieurs conditions:
1. entre quelques personnes en groupe different et par un nombre de dossier à distribuer fixé (ci-joint mon fichier feuil1, c'est les données de 18 colonnes, distribué par n°dossier, colonne K) ;
2. la feuil2, éviter à donner le dossier d'un branche pour la perso de même branche;
3. la perso ne peut pas être distribué pour certaine catégorie du dossier, tableau de la feuil2;
mais il faudrait tout distribuer ces dossiers et essayer assez diversifié distribué selon les catégorie du dossier. pouvez-vous m'aider un peu sur ce sujet? Ci-joint c'est le fichier.


Merci d'avance et bonne fête

Julie
 

Pièces jointes

  • Classeur1.xlsm
    119.9 KB · Affichages: 59
Dernière édition:
Trier par date Trier par votes
B

Bebere

XLDnaute Barbatruc
bonjour Julie
bienvenue
à mettre dans un module
tu peux supprimer la ligne commentée pour contrôle
Code: 
Sub distribue()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
 
    Feuil1.Range("R4:T35").ClearContents
    tbl1 = Feuil1.Range("A4:T35")
    tbl2 = Feuil2.Range("A2:H10")
    For j = 5 To UBound(tbl2, 2)
        For i = 2 To UBound(tbl2, 1)
            If tbl2(i, j) = "" Then
                For ii = 2 To UBound(tbl1, 1)
                    If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
                        tbl1(ii, 18) = tbl2(1, j)    'pour contrôle
                        tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2)    'perso,groupe
                    End If
                Next ii
            End If
        Next i
    Next j

    Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1

End Sub
 
Vote positif 0 Vote négatif
J

julie211

XLDnaute Nouveau
Bebere à dit:
bonjour Julie
bienvenue
à mettre dans un module
tu peux supprimer la ligne commentée pour contrôle
Code: 
Sub distribue()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long

    Feuil1.Range("R4:T35").ClearContents
    tbl1 = Feuil1.Range("A4:T35")
    tbl2 = Feuil2.Range("A2:H10")
    For j = 5 To UBound(tbl2, 2)
        For i = 2 To UBound(tbl2, 1)
            If tbl2(i, j) = "" Then
                For ii = 2 To UBound(tbl1, 1)
                    If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
                        tbl1(ii, 18) = tbl2(1, j)    'pour contrôle
                        tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2)    'perso,groupe
                    End If
                Next ii
            End If
        Next i
    Next j

    Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1

End Sub
Cliquez pour agrandir...

Merci, Bebere.
Après avoir testé, il ne peut pas finir à tout distribuer les données comme j'ajoute les conditions. Voici ci-joint le fichier avec les résultats, peux-tu le regarder et améliorer ?

Merci bien
 

Pièces jointes

  • Classeur1_v2.xlsm
    132.6 KB · Affichages: 51
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
bonjour Julie
code complété
Code: 
Sub distribue()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
    Application.ScreenUpdating = False
    Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
    tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
    tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
    For j = 5 To UBound(tbl2, 2)
        For i = 2 To UBound(tbl2, 1)
            If tbl2(i, j) = "" Then
                For ii = 2 To UBound(tbl1, 1)
                    If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
                        tbl1(ii, 18) = tbl2(1, j)    'pour contrôle,à effacer
                        tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2)    'perso,groupe
                    End If
                Next ii
            End If
        Next i
    Next j

    '    Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau
    Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19)    'remet la colonne 19,colonne S
    Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20)    'remet la colonne 20,colonne T
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
J

julie211

XLDnaute Nouveau
Bebere à dit:
bonjour Julie
code complété
Code: 
Sub distribue()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
    Application.ScreenUpdating = False
    Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
    tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
    tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
    For j = 5 To UBound(tbl2, 2)
        For i = 2 To UBound(tbl2, 1)
            If tbl2(i, j) = "" Then
                For ii = 2 To UBound(tbl1, 1)
                    If tbl1(ii, 3) = tbl2(1, j) And tbl1(ii, 1) = tbl2(i, 4) Then
                        tbl1(ii, 18) = tbl2(1, j)    'pour contrôle,à effacer
                        tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2)    'perso,groupe
                    End If
                Next ii
            End If
        Next i
    Next j

    '    Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau
    Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19)    'remet la colonne 19,colonne S
    Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20)    'remet la colonne 20,colonne T
    Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
Hello,

cela donne les memes resultats, il ne distribue pas tous les données, voici le fichier.
 

Pièces jointes

  • Classeur1_v2.xlsm
    140.8 KB · Affichages: 38
Vote positif 0 Vote négatif
J

julie211

XLDnaute Nouveau
c'est possible qu'on distribue d'abord aléatoirement par n°dossier et type catégorie (feuil1, plus une catégorie est représentée, plus on distribuera cette catégorie)? Puis on vérifie les conditions du feuil2 pour une rotation de redistribution si ne respect pas les conditions (à chaque distribution, on vérifie qu'il reste des lignes à faire, on décrémente les lignes jusqu'à zéro) ?
 
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
bonsoir
Julie maintenant parcourre d'abord tbl1 recherche concordance dossier
si trouve recherche concordance catégorie et si pas de x écrit

Code: 
Sub distribue1()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
    Application.ScreenUpdating = False
    Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
    tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
    tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
    For ii = 2 To UBound(tbl1, 1)
        For i = 2 To UBound(tbl2, 1)
            If tbl1(ii, 1) = tbl2(i, 4) Then
                For j = 5 To UBound(tbl2, 2)
                    If tbl1(ii, 3) = tbl2(1, j) Then
                        If tbl2(i, j) = "" Then
                            tbl1(ii, 18) = tbl2(1, j)    'pour contrôle,à effacer
                            tbl1(ii, 19) = tbl2(i, 1): tbl1(ii, 20) = tbl2(i, 2)    'perso,groupe
                        End If
                    End If
                Next j
            End If
        Next i
    Next ii
    '    Feuil1.Range("A4").Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1'remet tout le tableau
    Feuil1.Range("R4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 18)    'remet la colonne 18,colonne R
    Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19)    'remet la colonne 19,colonne S
    Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20)    'remet la colonne 20,colonne T
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
bonjour Julie
une autre version avec variable NbCategorie =nbre catégorie à placer
le code tient compte des dossiers de feuil2 présent dans feuil1
Code: 
Sub distribue2()
    Dim tbl1, tbl2, i As Long, ii As Long, j As Long, jj As Long
    Dim tbl2a(), NbCategorie As Long
    ii = 1: NbCategorie = Application.CountIf(Feuil2.Range("E3:Q25"), "=" & "")
    Application.ScreenUpdating = False
    Feuil1.Range("R5:T" & Feuil1.Range("A65536").End(xlUp).Row).ClearContents
    tbl1 = Feuil1.Range("A4:T" & Feuil1.Range("A65536").End(xlUp).Row)
    tbl2 = Feuil2.Range("A2:Q" & Feuil1.Range("A65536").End(xlUp).Row)
    For i = 2 To UBound(tbl2, 1)
'    If i > UBound(tbl2, 1) Then Exit For
        For j = 5 To UBound(tbl2, 2)
            If tbl2(i, j) = "" Then
                ReDim Preserve tbl2a(1 To 4, 1 To ii)
                tbl2a(1, ii) = tbl2(i, 4): tbl2a(2, ii) = tbl2(1, j): tbl2a(3, ii) = tbl2(i, 1)
                tbl2a(4, ii) = tbl2(i, 2):  If ii < NbCategorie Then ii = ii + 1
            End If
        Next j
  If ii = NbCategorie Then Exit For
    Next i
    tbl2a = Application.Transpose(tbl2a)
'       Feuil3.Range("A1").Resize(UBound(tbl2a, 1), UBound(tbl2a, 2)) = tbl2a 'remet tout le tableau
    For i = 2 To UBound(tbl1, 1)
        For ii = 2 To UBound(tbl2a, 1)
            If tbl1(i, 1) = tbl2a(ii, 1) And tbl1(i, 3) = tbl2a(ii, 2) Then
                tbl1(i, 18) = tbl2a(ii, 2)    'pour contrôle,à effacer
                tbl1(i, 19) = tbl2a(ii, 3): tbl1(i, 20) = tbl2a(ii, 4)    'perso,groupe
            End If
        Next ii
    Next i

    Feuil1.Range("S4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 19)    'remet la colonne 19,colonne S
    Feuil1.Range("T4").Resize(UBound(tbl1, 1)) = Application.Index(tbl1, , 20)    'remet la colonne 20,colonne T
    Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
J

julie211

XLDnaute Nouveau
Bonjour, Bebere

Merci bcp pour ton aide, mais cette version donne les mêmes résultats, ça ne distribue pas toute les données :( et ne correspond pas les contraintes de la feuil2:
1. ne correspond pas le nombre à distribuer pour chacun (feuil 2 , colonne C).
2. n’éviter pas les dossiers du même branche de n° perso (feuil 2, colonne D; Ex: il faut pas distribuer les dossiers d’Agen à n°perso:ctrl-05, car cette personne vient du même branche)
 
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Bonjour julie211, Bebere.

Un essai...​

Bonne soirée.

ℝOGER2327
#8435

Samedi 28 Sable 144 (Saint Cervelas, penseur - fête Suprême Quarte)
8 Nivôse An CCXXV, 6,9432h - fumier
2016-W52-3T16:39:49Z
 

Pièces jointes

  • Distribution sous conditions.xlsm
    144.2 KB · Affichages: 46
Vote positif 0 Vote négatif
J

julie211

XLDnaute Nouveau
ROGER2327 à dit:
Bonjour julie211, Bebere.

Un essai...​

Bonne soirée.

ℝOGER2327
#8435

Samedi 28 Sable 144 (Saint Cervelas, penseur - fête Suprême Quarte)
8 Nivôse An CCXXV, 6,9432h - fumier
2016-W52-3T16:39:49Z
Cliquez pour agrandir...
Bonjour, Roger et Bebere

Merci bcp, ca fonctionne super!
Roger, j'ai vu que tu utilise les randomize dans le macro, Peux-tu regarder ci-dessous ce fichier que je change un peu le structure de la feuil 1 pour faire un nombre de tirage sans doublons (sans doublons sur n°dossier, colonne K de la feuil1) sous certain contraintes (feuil2: nombre de sélection par branche, et certain branche seulement sur certaine catégorie du dossier), puis copie-coller la sélection dans la feuil 3 en même structure que la feuil 1 (en ordre croissant par nom du branche, catégorie et n°dossier) , puis retirer aléatoirement 120 depuis la feuil3 sans condition et copie coller dans feuil4 ?
(En faite, j'ai une grande données de la feuil 1 (environs 25000) pour tirer environs 6000 (dans feuil3), puis retirer 450 dans feuil4).

Bon après-midi
Julie
 

Pièces jointes

  • Distribution sous conditions_v2.xlsm
    137.6 KB · Affichages: 34
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
Comment faire une recherche sur plusieurs feuilles dans un classeur?(nom ou ref)
Réponses
10
Affichages
13 K
craigthefrenchy
C
M
[REF] Wiki 5 de MichelXld (Formules, Audits de formules, Répertoires, Fichiers)
Réponses
0
Affichages
46 K
MichelXld
M

Membres actuellement en ligne

5 membres et 38 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 348
Messages
2 087 508
Membres
103 568
dernier inscrit
NoS