XL 2013 Supprimer des doublons pendant un loop - Résolu par Dranreb.

Lone-wolf · 3 Septembre 2020

Bonjour le Forum,

Après plusieures tentatives faite avec Dictionnary, if cells(k, 3) = cells(k-1) then, boucle for each etc. Je me tourne vers vous pour trouvez une solution au problème.
En PJ, le fichier pour test.

patricktoulon · 3 Septembre 2020

bonjour lone-Wolf
au regard de la plage de test je ne suis pas sur que tu est besoins d'un dico
un test simple à la volée avec countif

VB:

Sub test()
    For i = 5 To 10
        If WorksheetFunction.CountIf(Range("B5", Cells(i, 2)), Cells(i, 2)) = 1 Then texte = texte & Cells(i, 2) & "  ligne(" & i & ")" & vbCrLf
    Next
    MsgBox texte
End Sub

comme la plage s'agrandi au fur et a mesure de "i" tu a les uniques et le premier des doublons

maintenant si tu veux vraiment faire péter les doublons le test se fait non plus sur la plage progréssée mais la plage entière

VB:

Sub test2()
    For i = 5 To 10
        If WorksheetFunction.CountIf(Range("B5", Cells(10, 2)), Cells(i, 2)) = 1 Then texte = texte & Cells(i, 2) & "  ligne(" & i & ")" & vbCrLf
    Next
    MsgBox texte
End Sub

dans les deux modele c'est la colonne B qui sert de controle mais tu peux choisr la colonne de données a mettre dans texte ou un tableau comme tu veux
pas de dico

Lone-wolf · 3 Septembre 2020

Bonjour Patrick,
merci d'être intervenu.

Comme tu as pu le voir dans le fichier, jutilise un do loop pour afficher une à une les cartes. Il faudrait supprimer les doublons, puis inscrire les uniques un à un. Et c'est là mon problème, comment faire?

patricktoulon · 3 Septembre 2020

j'avoue ne pas très bien comprendre
ton ""do loop"" tout au plus constitue un temps de pause pour ta boucle for dans la quelle il est imbriqué

patricktoulon · 3 Septembre 2020

ok si tu ne veux pas de doublons au tirage de l'ordi
"remelange et retire" a la source
ici

VB:

re:
   Cells(k, 3) = carteOrdi(((nb * Rnd) + 1))
  If WorksheetFunction.CountIf(Range("c5", Cells(10, 3)), Cells(k, 3)) >= 1 Then GoTo re

je ne sais pas a quoi te sert le do loop mais tu peux virer

édit:
petite correction
code a reprendre

Lone-wolf · 3 Septembre 2020

Re,

le do loop sert à afficher les cartes une à une. Dans le vrai jeu, le croupier distribue les cartes une à une et non les 5 ou 6 ensemble.

patricktoulon · 3 Septembre 2020

ok c'est donc la sub complete qui devrait etre lancée X fois
en l'état ton do loop ne fait que ralentir la boucle for
ce la dit si tu a ajouté les deux lignes que je t'ai donné tu n'aura pas de doublons dans le tirage

Lone-wolf · 3 Septembre 2020

Re Patrick,

En mettant le code dans la boucle, les données sont affichée quand B5, il ya moyen de les incrire avec, par exemple: k = Range("c" & Rows.Count).End(xlUp).Row +1 ?
WorksheetFunction.CountIf(Range("c" & k), ..... .

Dranreb · 3 Septembre 2020

Bonjour.
Il s'agit de quoi, au fond ? Simplement de tirer 6 cartes au hasard d'un jeu de 52 ?

Dranreb · 3 Septembre 2020

Parce que si c'est ça je le ferais comme ça, en supposant un délai de 2 secondes entre chaque apparition d'une carte :

VB:

Option Explicit
Private LAt As New ListeAléat, P As Long
Sub Jeu_Ordi()
   Randomize
   LAt.Init 52
   Range("B5:C10").ClearContents
   P = 0
   Application.OnTime Now + TimeSerial(0, 0, 3), "TirerUneCarte"
   End Sub
Sub TirerUneCarte()
   Dim Carte As Long
   P = P + 1: Carte = LAt.Aléat(P)
   Cells(4 + P, 2).Value = Carte
   Cells(4 + P, 3) = NomCarte(Carte)
   If P < 6 Then Application.OnTime Now + TimeSerial(0, 0, 2), "TirerUneCarte"
   End Sub
Function NomCarte(ByVal N As Long) As String
   NomCarte = Choose((N - 1) Mod 13 + 1, "as", "deux", "trois", "quatre", "cinq", _
      "six", "sept", "huit", "neuf", "dix", "valet", "dame", "roi") & " de " & _
      Choose((N - 1) \ 13 + 1, "cœur", "carreau", "pique", "trèfle")
   End Function

Nécessite mon module de classe ListeAléat, à glisser/déplacer depuis le projet VBA de ce classeur.

patricktoulon · 3 Septembre 2020

Re
Bonjour Dranreb
je me suis poser la même question que toi Dranreb

Lone-wolf · 3 Septembre 2020

Bonsoir Dranreb , re Patrick

Dranreb, comme d'hab t'es un génie. J'ai adapté la macro "jeu tirer une carte" à ma sauce pour pouvoir comptabiliser les valeurs des cartes. Merci infiniment. Sujet résolu.

Très bonne soirée à tous les deux.

Lone-wolf · 3 Septembre 2020

EDIT

Re Dranreb, Patrick

Voici le code avec les modifs, mais en cours d'amelioration.

VB:

Sub TirerUneCarte()
    Dim Carte As Long, i As Byte
   
    P = P + 1: Carte = LAt.Aléat(P)
    Cells(4 + P, 3) = NomCarte(Carte)
    Cells(4 + P, 2).Value = Split(Cells(4 + P, 3), " de")(0)

    Select Case Cells(4 + P, 2)
    Case "as": num = 1
    Case "deux": num = 2
    Case "trois": num = 3
    Case "quatre": num = 4
    Case "cinq": num = 5
    Case "six": num = 6
    Case "sept": num = 7
    Case "huit": num = 8
    Case "neuf": num = 9
    Case Else
        num = 10
    End Select
    Cells(4 + P, 4).Value = num
    Range("d2") = Range("d5") + Range("d6") + Range("d7") + Range("d8") + Range("d9") + Range("d10")


    If Range("d2") > Range("b2") And Range("d2") < 21 Then Range("c3") = "La banque gagne !": Exit Sub
    If Range("d2") > Range("b2") And Range("d2") = 21 Then Range("c3") = "La banque gagne !": Exit Sub

    If Range("d2") > Range("b2") And Range("d2") > 21 Then Range("c3") = "Le joueur gagne !": Exit Sub
    If Range("d2") = Range("b2") And Range("d2") < 21 Then Range("c3") = "Egalité !": Exit Sub

    If Range("b5") = "as" And Range("b6") = "dix" Then Range("d2") = Range("d2") + 10: Range("c2") = "BLACK JACK": Exit Sub
    If Range("b5") = "dix" And Range("b6") = "as" Then Range("d2") = Range("d2") + 10: Range("c2") = "BLACK JACK": Exit Sub

    If Range("b5") = "as" And Range("b6") = "valet" Then Range("d2") = Range("d2") + 10: Range("c2") = "BLACK JACK": Exit Sub
    If Range("b5") = "valet" And Range("b6") = "as" Then Range("d2") = Range("d2") + 10: Range("c2") = "BLACK JACK": Exit Sub

    If Range("b5") = "as" And Range("b6") = "dame" Then Range("d2") = Range("d2") + 10: Range("c2") = "BLACK JACK": Exit Sub
    If Range("b5") = "dame" And Range("b6") = "as" Then Range("d2") = Range("d2") + 10:  Range("c2") = "BLACK JACK": Exit Sub

    If Range("b5") = "as" And Range("b6") = "rois" Then Range("d2") = Range("d2") + 10:  Range("c2") = "BLACK JACK": Exit Sub
    If Range("b5") = "rois" And Range("b6") = "as" Then Range("d2") = Range("d2") + 10:  Range("c2") = "BLACK JACK": Exit Sub

    If Range("b5") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10
    If Range("b6") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10
    If Range("b7") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10
    If Range("b8") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10
    If Range("b9") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10
    If Range("b10") = "as" And Range("d2") <= 11 Then Range("d2") = Range("d2") + 10

    If Range("d2") > 20 And Range("d2") <= 24 Then Exit Sub


    If P < 7 Then Application.OnTime Now + TimeSerial(0, 0, 1), "TirerUneCarte"

End Sub

Dranreb · 3 Septembre 2020

Pourriez quand même simplifier au moins le calcul de num :

VB:

num = (Carte - 1) Mod 13 + 1: If num > 10 Then num = 10

et sans doute le reste aussi …

Lone-wolf · 4 Septembre 2020

Bonjour Dranreb,

je suis à des milliers de kilomètres d'être doué comme toi, et en conséquence je fais les choses au plus simple. Il y a peu de temps, je me suis intêressé à Select Case qui est plus sûr et éfficace; et je l'utilise de façon basic, n'étant pas un farouche programmeur. Comme je peux le constater, il y a encore plus simple, mais il m'est impossible d'en arriver là, vu mon niveau.

Sans vouloir abuser, pourrais-tu me montrer comment simplifier ceci. C'est un code pris sur un ancien fichier fait avec des label's. Personnellement, j'aimerais le modifier en Select Case, mais si tu as un meilleur exemple à me donner, ce serait sympa de ta part. Merci d'avance.

VB:

        If Range("b2") < 21 And Range("b2") > Range("d2") Then
            Range("c3") = "Le joueur gagne"
            Range("l22") = Range("l22") + Range("l25")
        ElseIf Range("d2") > 21 And Range("b2") < 21 Then
            Range("c3") = "Le joueur gagne"
            Range("l22") = Range("l22") + Range("l25")
        ElseIf Range("d2") > 21 And Range("d2") < 21 Then
            Range("c3") = "Le joueur gagne"
            Range("l22") = Range("l22") + Range("l25")
        ElseIf Range("b2") = 21 And Range("d2") <> 21 Then
            Range("c3") = "Le joueur gagne"
            Range("l22") = Range("l22") + Range("l25") + (Range("l22") / 2)  '<- mise de départ ex.: 100.  Partage en deux entre la banque et le joueur.
        ElseIf Range("d2") = 21 And Range("b2") <> 21 Then
            Range("c3") = "La banque gagne"
            Range("l22") = Range("l22") - Range("l25")
        ElseIf Range("d2") < 21 And Range("d2") > Range("b2") Then
            Range("c3") = "La banque gagne"
            Range("l22") = Range("l22") - Range("l25")
        ElseIf Range("b2") > 21 And Range("d2") < 21 Then
            Range("c3") = "La banque gagne"
            Range("l22") = Range("l22") - Range("l25")
        ElseIf Range("b2") = 21 And Range("d2") = 21 Then
            Range("c3") = "Égalité"
        ElseIf Range("d2") = Range("b2") Then
            Range("c3") = "Égalité"
        End If

XL 2013 Supprimer des doublons pendant un loop - Résolu par Dranreb.

Lone-wolf

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Pièces jointes

Dranreb

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Discussions similaires