Lecture VBA difficile
Bonjour les VBistes,
Je suis en difficulté pour lire une portion de code que j'aimerais commenter, afin de mieux m'y retrouver.
si par la même occasion quelqu'un peut m'expliquer l'erreur générée par la ligne en rouge, ce serait parfait pour que je puisse avancer.
Option Explicit
Sub tirage()
Dim v%, equipe% 'Déclaration de variables (As Integer)
Dim f%, h%, col%, joueur%
Dim n&
Dim nom$, prénom$ 'Déclaration de variables (As Long)
Dim sh1 'Déclaration de variables
Dim DicoH As New Scripting.Dictionary ' Objet qui stocke des paires clé/élément de données.
Dim DicoF As New Scripting.Dictionary ' "DicoH" pour les hommes et "DicoF" pour les femmes
Application.ScreenUpdating = False 'Désactive l'actualisation de l'écran pour accélérer l'exécution
Set sh1 = Sheets("Feuil3") 'Attribue une référence d'objet à la variable "sh1"
h = Evaluate("COUNTIF(" & sh1.Name & "!C:C,""H"")") 'h = valeur de la cellule ligne 2/colonne 10 de la feuille sh1
f = Evaluate("COUNTIF(" & sh1.Name & "!C:C,""F"")") 'f = valeur de la cellule ligne 3/colonne 10 de la feuille sh1
equipe = Application.Ceiling(h / 2, 1)
' et sh1 = Sheets("Feuil3")
col = 14 'Attribue une valeur à la variable "col", numéro de colonne où s'inscrit le résultat
n = 1 'Attribue une valeur à la variable "n"
'homme
Do Until DicoH.Count = h ' faire tant que le nombre d'éléments de la collection de l'objet "DicoH" est inférieur ou égal à "h". Lecture seule.
v = Int((h) * Rnd() + 1)
If Not DicoH.Exists(v) Then
DicoH.Add v, ""
joueur = Application.Match("H" & v, sh1.Range("G:G"), 0)
nom = Application.Index(sh1.Range("A:A"), joueur)
prénom = Application.Index(sh1.Range("B:B"), joueur)
sh1.Cells(n + 1, col) = nom & "-" & prénom
sh1.Cells(n + 1, col + 5) = "H" & v 'Test Vérif. Doublon colonne S, T, U
n = n + 1
If n = equipe + 1 Then col = col + 1: n = 1
End If
Loop
n = 1
col = col + 1
'femme
Do Until DicoF.Count = f
v = Int((f) * Rnd() + 1)
If Not DicoF.Exists(v) Then
DicoF.Add v, ""
joueur = Application.Match("F" & v, sh1.Range("G:G"), 0)
nom = Application.Index(sh1.Range("A:A"), joueur)
prénom = Application.Index(sh1.Range("B:B"), joueur)
sh1.Cells(n + 1, col) = nom & "-" & prénom
sh1.Cells(n + 1, col + 5) = "F" & v 'Test Vérif. Doublon colonne S, T, U
n = n + 1
If n = equipe + 1 Then col = col + 1: n = 1
End If
Loop
Application.ScreenUpdating = True ' Résactive l'actualisation de l'écran
End Sub
Merci de l'aide que vous voudrez bien m'apporter.
Mon ficher joint:
Bonjour atlonia,
'homme
Do Until DicoH.Count = h 'Faire jusqu'à ce que le dico soit rempli à la valeur de h
v = Int((h) * Rnd() + 1) 'tirage au sort
If Not DicoH.Exists(v) Then ' vérifier que le tirage au sort n'est pas dans le dico
DicoH.Add v, "" ' le nombre n'est pas dans le dico alors ajout du nombre
joueur = Application.Match("H" & v, sh1.Range("G:G"), 0) 'trouve la ligne correspondance dans la colonne G de la valeur "H" & v
nom = Application.Index(sh1.Range("A:A"), joueur) 'nom (colonne A) de la ligne correspondance
prénom = Application.Index(sh1.Range("B:B"), joueur) 'prénom (colonne B) de la ligne correspondance
sh1.Cells(n + 1, col) = nom & "-" & prénom ' inscrit Nom et prénom en colonne N (N=14)
sh1.Cells(n + 1, col + 5) = "H" & v ' pas nécessaire juste pour vérifier -->Test Vérif. Doublon colonne S, T, U
n = n + 1 ' changement de ligne pour inscription nom et prénom
If n = equipe + 1 Then col = col + 1: n = 1 ' si le nombre de "premier" joueurs pour chaque équipe est atteint on passe à la colonne suivante (O)
End If
Loop
n = 1 ' remettre le numéro de ligne à 1 pour la prochaine boucle Femme
col = col + 1 ' on passe à la colonne suivante (P) pour la prochaine boucle Femmeedit: l'erreur mentionné peut se produire s'il n'y a pas l'information "sexe" en colonne C
pour remédier à ce problème, vous pouvez ajouter ces lignes en début de macro,
If Application.CountIf(sh1.Range("C:C"), "H") + Application.CountIf(sh1.Range("C:C"), "F") <> Application.CountA(sh1.Range("A:A")) - 1 Then
MsgBox "Vous devez inscrire l'information (sexe) pour tous les joueurs"
Exit Sub
End IfBonjour atlonia,
j'ai fais quelque modification, pour la colonne G: calcul par vba au lieu d'une formule
et ajout de la vérification si la colonne C est entièrement renseignée
j'ai enlevé les vérifications "doublon" colonne H, S, T, U qui ne sont plus nécessaire.
bonsoir sabV,
Ton code est super, merci de l'avoir commenté, ça me permet d'y voir un peu plus clair, mais je commence à peine à pouvoir le comprendre je suis encore loin de pouvoir le modifier pour l'intégrer à mon projet final...!
J'ai bien essayé, mais j'ai la tête qui fume
J'ai fait un teste sur le fichier que tu l'a renvoyé en allongeant la liste des hommes inscrits au concours, et là, j'ai vu que le tirage, lorsqu'il n'y avait plus de femmes constituait des équipes de 2 joueurs au lieu de compléter en équipes de 3...!
Exemple dans le classeur "sabV_Tirage_equipes (1).xlsm"
Dans l'autre, tu trouveras en feuille "Tirage Equipes" un exemple du résultat que je souhaiterais avoir,
J'ai copier/collé le code de ton dernier poste en module: "New Tirage" de mon projet final, l'ancien est en" module3".
Merci de partager tes connaissances avec un débutant qui rame pour y arriver, mais qui ne d&sespère pas d'y arriver un jour.
PS: Si tu veux essayer mon programme, il faut cliquer sur le joueur en feuille "Menu".
Bonjour atlonia,
j'ai fait une modification pour inclure tous les joueurs, et adapter pour l'onglet Tirages Equipes bouton "Triplette"
je n'ai pas fait les 2 autre car je ne connais pas les règles.
dit-moi si ça va,
Bonsoir sabV,
J'ai testé ta macro sur une copie de du classeur que tu m'envois en retour testé ta macro, 1er tirage, super.
Puis j'ai supprimé des lignes de joueurs, vidé le tableau "Tirage des équipes" de la "Feuil3" par une sélection de plage, puis touche [Suppr] du clavier.
J'ai procédé de même pour le tableau "Triplettes" de la feuille "Tirage Equipes".
Et enfin relancé le tirage...!
J'ai obtenu le résultat que tu peux voir en "Feuil3" et en feuille "Tirage Equipes", tableau "Triplettes" du classeur joint ????
J'ai créé un autre module pour essayer sur le tableau "Doublettes", mais le résultat n'est pas plus probant.
J'ai utilisé le "Pas à pas détailé" qui boucle sur ces 3 ligne
'liste homme et femme numéroté --> colonne G
Application.EnableEvents = False
For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
If sh1.Range("C" & i) = "H" Then sh1.Range("G" & i) = "H" & Application.CountIf(sh1.Range("C2:C" & i), "H")
If sh1.Range("C" & i) = "F" Then sh1.Range("G" & i) = "F" & Application.CountIf(sh1.Range("C2:C" & i), "F")
Next
Application.EnableEvents = True
h = Evaluate("COUNTIF(" & sh1.Name & "!C:C,""H"")") 'h = la valeur de la cellule en ligne 2 et colonne 10 de la feuille sh1
f = Evaluate("COUNTIF(" & sh1.Name & "!C:C,""F"")") 'f = la valeur de la cellule en ligne 3 et colonne 10 de la feuille sh1
equipe = Application.Ceiling((h + f) / 3, 1)
' et sh1 = Sheets("Feuil3")
col = 14 'Attribue une valeur à la variable "col", numéro de colonne où s'inscrit le résultat
n = 1 'Attribue une valeur à la variable "n"
J'ai pas compris en quoi le fait de supprimer des lignes dans la liste des joueurs pouvais perturber la procédure...!
Pour les 2 autres tirages, les règles sont simples:
Doublettes => 1 H et 1 F, 1 tireur et 1 (pointeur ou milieu) tant que c'est possible , puis on complète les équipes comme pour les triplettes.
Tête à tête: un tirage aléatoire simple avec transfert direct en feuille "Tirage Equipes", tableau "Tête à tête".
tu peut trouver l'explication dans la Feuille "INFO" du 1ème classeur que j'ai fourni dans mon post précédent.
Merci encore pour les efforts que tu déploies pour m'aider.
PS: y-a-t'il un moyen de ne pas passer par le tableau de la "Feui3" et d'avoir un envoi direct du tirage en feuille"Tirage Equipes"...?
Bonjour atlonia,
voilà une nouvelle bouture,
j'utilise toujours le tableau de la "Feui3", mais cette feuil peut être masquer
dit-moi si ça va ?
Bonsoir sabV,
Superbe travail...!
Dernier petit détail: j'ai 59 joueur d'inscrits, 19 équipes de 3 joueurs dans les triplettes, donc 57 joueurs, il faudrait que les 2 joueurs qui restent soient inscrits comme 20 ème équipe.
Ils joueront avec 3 boules contre 2 boules pour les autres équipes.
Merci encore pour ta persévérance et ton altruisme...!
Bonjour atlonia,
remplace la macro Triplettes par celle-ci, étant donné qu'il peut y avoir 1 ou 2 joueurs mit à l'écart, j'ai ajouté 2 lignes à la macro
dit-moi si ça va ?
Sub Triplettes()
Dim i As Long, y As Long
tirage 3
y = 3
Sheets("Tirages Equipes").Range("M3:N100").ClearContents
For i = 2 To Sheets("Feuil3").Cells(Rows.Count, 14).End(xlUp).Row
Sheets("Tirages Equipes").Range("M" & y) = Sheets("Feuil3").Range("N" & i)
Sheets("Tirages Equipes").Range("M" & y + 1) = Sheets("Feuil3").Range("O" & i)
Sheets("Tirages Equipes").Range("M" & y + 2) = Sheets("Feuil3").Range("P" & i)
y = y + 3
Next
Sheets("Tirages Equipes").Range("M" & y) = Sheets("Feuil3").Range("Q2")
Sheets("Tirages Equipes").Range("M" & y + 1) = Sheets("Feuil3").Range("Q3")
End Subps/ les données de la feuil3 pourrait être sur l'onglet des inscrptions, dans les colonnes plus à droite
je sens le crochet "résolue" qui est proche
une autre possibilité, serait de remplacer Floor par Ceiling dans la macro Sub tirage(equip As Integer)
mais cette modification aura un impact sur la macro Triplettes et aussi sur la macro Doublettes, à toi de voir
voici le fichier,
Bonjours sabV,
C'est de la "Bombe"...
Ton code fonctionne à merveille.
Un GRANNND merci a toi.
En espérant te retrouver sur d'autres post, car je m'attaque maintenant au tirage des poules, c'est le plus gros morceau, et je pense encore avoir besoin de toi et de toutes les bonnes volontés du forum.
Merci encore, A+