Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

condition VBA

vincent noah

XLDnaute Junior
Bonjour à tous , heureux de vous retrouver !!

voici un extrait de mon code:
VB:
Sub combinaisons()
Dim lin&, col&, rc&, m%, n%, o%, p%, q%, tir$()
lin = 1
col = 0
rc = Rows.Count
ReDim tir(1 To rc, 0)
    For m = 1 To 20
        For n = m + 1 To 20
            For o = n + 1 To 20
                For p = o + 1 To 20
                    For q = p + 1 To 20

voila j'ai une petite difficulté à trouver l'expression exacte VBA pour ne pas faire apparaître la combinaison qui contient par exemple le n° 1 et ( 7,6,9,10) . etc .
j'ai bien compris qu'il faut que je combine toutes les possibilités parmi m ,n ,o, p, q (2 parmi 10
) donc trop long .
ne pourrez t'on pas faire plus court du genre : if not armi (m , n, o, p, q ) il y'a (1 et 7 )ou (1 et 6) ou (1et9) ou (1et 10) then
?
voila je bloque là dessus pourtant cela me semble simple

j'espère était clair. merci de votre aide

bonne soirée.
 

vincent noah

XLDnaute Junior
re ,
les couples avec le numéros 1 à exclure:
1 et 5.
1 et 2
1et 9
1 et 6
1 et 12
1 et 13 .
les couples avec le numéros 2 à exclure :
2 et 6
2 et 3
2 et 7
les couples avec le numéros 3 à exclure :
3 et 14
3 et 19
3 et 7
3 et 20.

les couples avec le numéros 4 à exclure :
etc ..

j’espère que c'est plus claire ?

Merci A+
 

job75

XLDnaute Barbatruc
Re,

Bon allez, je me base sur les couples du post #17 :
Code:
Sub Combinaisons()
Dim nmax%, exclu, Ncombi&, rc&, tablo$(), col%, d As Object, m%, n%, o%, p%, q%, lig&
nmax = 20 'modifiable
exclu = Array("1 2", "1 5", "1 6", "1 9", "1 12", "1 13", "2 3", "2 6", "2 7", "7 13", "7 14", "7 18") 'liste modifiable
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
MsgBox Ncombi
rc = Rows.Count
ReDim tablo(1 To rc, 1 To Int(Ncombi / rc) + 1)
col = 1
Set d = CreateObject("Scripting.Dictionary")
For m = 0 To UBound(exclu): d(exclu(m)) = "": Next
For m = 1 To nmax
  For n = m + 1 To nmax
    If d.exists(m & " " & n) Then GoTo 1
    For o = n + 1 To nmax
      If d.exists(n & " " & o) Then GoTo 2
      For p = o + 1 To nmax
        If d.exists(o & " " & p) Then GoTo 3
        For q = p + 1 To nmax
          If d.exists(p & " " & q) Then GoTo 4
          lig = lig + 1
          tablo(lig, col) = m & " " & n & " " & o & " " & p & " " & q
          If lig = rc Then lig = 0: col = col + 1
4       Next q
3     Next p
2   Next o
1 Next n
Next m
Cells.ClearContents
[A1].Resize(IIf(col = 1, lig, rc), col) = tablo
Columns.AutoFit 'ajustement largeur
End Sub
A+
 

vincent noah

XLDnaute Junior
re,
presque mais non ! le couple 2,6 par exemple doit être exclu mais il est affiché
aussi le couple 7,18
lorsque j'ai ouvert la discutions je me suis dit c'est une question bête et la réponse était évidente
je m’aperçois combien c'est un gros problème .

A+
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour vincent noah, le forum,

La macro du post #21 excluait les couples se trouvant dans 2 nombres consécutifs d'une combinaison.

Celle-ci exclut les couples se trouvant n'importe où dans une combinaison :
Code:
Dim dico As Object 'mémorise la variable

Function Couple(x%, a%, Optional b%, Optional c%, Optional d%) As Boolean
If dico.exists(a & " " & x) Then Couple = True: Exit Function
If b = 0 Then Exit Function Else If dico.exists(b & " " & x) Then Couple = True: Exit Function
If c = 0 Then Exit Function Else If dico.exists(c & " " & x) Then Couple = True: Exit Function
If d Then If dico.exists(d & " " & x) Then Couple = True
End Function

Sub Combinaisons()
Dim nmax%, exclu, Ncombi&, rc&, tablo$(), m%, n%, o%, p%, q%, lig&, col%
nmax = 20 'modifiable
exclu = Array("1 2", "1 5", "1 6", "1 9", "1 12", "1 13", "2 3", "2 6", "2 7", "7 13", "7 14", "7 18") 'liste modifiable
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dico = CreateObject("Scripting.Dictionary")
For m = 0 To UBound(exclu): dico(exclu(m)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    If Couple(n, m) Then GoTo 1
    For o = n + 1 To nmax - 2
      If Couple(o, m, n) Then GoTo 2
      For p = o + 1 To nmax - 1
        If Couple(p, m, n, o) Then GoTo 3
        For q = p + 1 To nmax
          If Couple(q, m, n, o, p) Then GoTo 4
          lig = lig + 1
          tablo(lig, col) = m & " " & n & " " & o & " " & p & " " & q
          If lig = rc Then lig = 0: col = col + 1
4       Next q
3     Next p
2   Next o
1 Next n
Next m
[A1].CurrentRegion.ClearContents 'RAZ
[A1].Resize(IIf(col, rc, lig), col + 1) = tablo
Columns(1).Resize(, col + 1).AutoFit 'ajustement largeur
End Sub
Nota : la fonction Couple n'est pas indispensable, je l'ai mise pour alléger le code et elle fait aussi gagner un peu de temps.

Edit : avec nmax - 4, nmax - 3, nmax - 2, nmax - 1 c'est un chouia plus rapide.

Fichier joint.

Bonne journée.
 

Pièces jointes

  • Combinaisons(1).xlsm
    26.8 KB · Affichages: 35
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Autre hypothèse, sont exclus les couples dont le 1er élément est en tête d'une combinaison :
Code:
Sub Combinaisons()
Dim nmax%, exclu, Ncombi&, rc&, tablo$(), dico As Object, m%, n%, o%, p%, q%, lig&, col%
nmax = 20 'modifiable
exclu = Array("1 2", "1 5", "1 6", "1 9", "1 12", "1 13", "2 3", "2 6", "2 7", "7 13", "7 14", "7 18") 'liste modifiable
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dico = CreateObject("Scripting.Dictionary")
For m = 0 To UBound(exclu): dico(exclu(m)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    If dico.exists(m & " " & n) Then GoTo 1
    For o = n + 1 To nmax - 2
      If dico.exists(m & " " & o) Then GoTo 2
      For p = o + 1 To nmax - 1
        If dico.exists(m & " " & p) Then GoTo 3
        For q = p + 1 To nmax
          If dico.exists(m & " " & q) Then GoTo 4
          lig = lig + 1
          tablo(lig, col) = m & " " & n & " " & o & " " & p & " " & q
          If lig = rc Then lig = 0: col = col + 1
4       Next q
3     Next p
2   Next o
1 Next n
Next m
[A1].CurrentRegion.ClearContents 'RAZ
[A1].Resize(IIf(col, rc, lig), col + 1) = tablo
Columns(1).Resize(, col + 1).AutoFit 'ajustement largeur
End Sub
Les tests étant moins nombreux la macro est plus rapide.

Fichier (2).

A+
 

Pièces jointes

  • Combinaisons(2).xlsm
    26.2 KB · Affichages: 27
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Dans le tableau exclu vous pouvez ajouter autant de couples que vous voulez.

Bien sûr avec nmax = 20 la limite est le nombre de combinaisons 20 * 19 / 2 = 190.

Le tableau maximum :
Code:
exclu = Array("1 2", "1 3", "1 4", "1 5", "1 6", "1 7", "1 8", "1 9", "1 10", "1 11", "1 12", "1 13", "1 14", "1 15", "1 16", "1 17", "1 18", "1 19", "1 20", _
  "2 3", "2 4", "2 5", "2 6", "2 7", "2 8", "2 9", "2 10", "2 11", "2 12", "2 13", "2 14", "2 15", "2 16", "2 17", "2 18", "2 19", "2 20", _
         "3 4", "3 5", "3 6", "3 7", "3 8", "3 9", "3 10", "3 11", "3 12", "3 13", "3 14", "3 15", "3 16", "3 17", "3 18", "3 19", "3 20", _
                "4 5", "4 6", "4 7", "4 8", "4 9", "4 10", "4 11", "4 12", "4 13", "4 14", "4 15", "4 16", "4 17", "4 18", "4 19", "4 20", _
                       "5 6", "5 7", "5 8", "5 9", "5 10", "5 11", "5 12", "5 13", "5 14", "5 15", "5 16", "5 17", "5 18", "5 19", "5 20", _
                              "6 7", "6 8", "6 9", "6 10", "6 11", "6 12", "6 13", "6 14", "6 15", "6 16", "6 17", "6 18", "6 19", "6 20", _
                                     "7 8", "7 9", "7 10", "7 11", "7 12", "7 13", "7 14", "7 15", "7 16", "7 17", "7 18", "7 19", "7 20", _
                                            "8 9", "8 10", "8 11", "8 12", "8 13", "8 14", "8 15", "8 16", "8 17", "8 18", "8 19", "8 20", _
                                                   "9 10", "9 11", "9 12", "9 13", "9 14", "9 15", "9 16", "9 17", "9 18", "9 19", "9 20", _
                                                 "10 11", "10 12", "10 13", "10 14", "10 15", "10 16", "10 17", "10 18", "10 19", "10 20", _
                                                          "11 12", "11 13", "11 14", "11 15", "11 16", "11 17", "11 18", "11 19", "11 20", _
                                                                   "12 13", "12 14", "12 15", "12 16", "12 17", "12 18", "12 19", "12 20", _
                                                                            "13 14", "13 15", "13 16", "13 17", "13 18", "13 19", "13 20", _
                                                                                     "14 15", "14 16", "14 17", "14 18", "14 19", "14 20", _
                                                                                              "15 16", "15 17", "15 18", "15 19", "15 20", _
                                                                                                       "16 17", "16 18", "16 19", "16 20", _
                                                                                                                "17 18", "17 19", "17 20", _
                                                                                                                         "18 19", "18 20", _
                                                                                                                                  "19 20")
S'il n'y a plus de lignes à lister la macro beugue à la fin, pour l'éviter on peut compléter :
Code:
If lig Or col Then [A1].Resize(IIf(col, rc, lig), col + 1) = tablo
A+
 

Dranreb

XLDnaute Barbatruc
Bonsoir.
J'ai cette fonction qui peut vous intéresser :
VB:
Public Function NumVS(ByVal J As Long, ByVal A As Long) As Long
If J > A Then
   NumVS = J * (J - 3) \ 2 + A + 1
ElseIf J < A Then
   NumVS = A * (A - 3) \ 2 + J + 1
Else: NumVS = 0: End If
If NumVS <= 0 Then Err.Raise 9999, , "NumVS(" & J & ", " & A & ") impossible."
End Function
Elle renvoie un indice de tableau à une dimension basé 1 en fonction de 2 entiers différents censés représenter les indices dans un tableau fictif triangulaire sans diagonale ainsi matérialisé.
Pour des indices allant jusqu'à 20 prenez NumVS(20, 19) comme dimension unique maxi du tableau de couples. (ou bien NumVS(19, 20), c'est pareil)

Pour info, j'ai aussi la fonction inverse qui retrouve les numéros de joueur et d'adversaire en fonction du numéro de versus :
VB:
Public Function Versus(ByVal VS As Long) As Variant()
Dim J As Long, A As Long
A = Int(Sqr(2 * VS - 1.75) + 1.5)
J = VS - A * (A - 3) \ 2 - 1
Versus = Array(J, A)
End Function
 
Dernière édition:

job75

XLDnaute Barbatruc
Re,
Une dernière question : si je veux inverser le code et ne garder que les couples souhaité
peux-tu m'indiquer la manip stp ?
Utilisez alors cette macro :
Code:
Sub Combinaisons()
Dim nmax%, garder, Ncombi&, rc&, tablo$(), m%, n%, o%, p%, q%, g1, g2, g3, g4, lig&, col%
nmax = 20 'modifiable
garder = Array("1 2", "1 5", "1 6", "1 9", "1 12", "1 13", "2 3", "2 6", "2 7", "7 13", "7 14", "7 18") 'liste modifiable
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dico = CreateObject("Scripting.Dictionary")
For m = 0 To UBound(garder): dico(garder(m)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    g1 = Couple(n, m)
    For o = n + 1 To nmax - 2
      If g1 Then g2 = True Else g2 = Couple(o, m, n)
      For p = o + 1 To nmax - 1
        If g2 Then g3 = True Else g3 = Couple(p, m, n, o)
        For q = p + 1 To nmax
          If g3 Then g4 = True Else g4 = Couple(q, m, n, o, p)
          If g4 Then
            lig = lig + 1
            tablo(lig, col) = m & " " & n & " " & o & " " & p & " " & q
            If lig = rc Then lig = 0: col = col + 1
          End If
Next q, p, o, n, m
[A1].CurrentRegion.ClearContents 'RAZ
If lig Or col Then [A1].Resize(IIf(col, rc, lig), col + 1) = tablo
Columns(1).Resize(, col + 1).AutoFit 'ajustement largeur
End Sub

Fichier (3).

Edit : pour faire bon poids j'ajoute aussi le fichier (4), parallèle au fichier (2).

Bonne nuit.
 

Pièces jointes

  • Combinaisons(3).xlsm
    26 KB · Affichages: 28
  • Combinaisons(4).xlsm
    26.4 KB · Affichages: 29
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…