condition VBA

vincent noah · 7 Avril 2017

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.

job75 · 16 Avril 2017

Re,

Dites-nous clairement et une fois pour toutes quels sont les couples de 2 nombres qu'il faut exclure.

A+

vincent noah · 16 Avril 2017

re,
et bien le 1 et ( 5, 2, 9, 6, 12, 13) .
le 2 avec ( 6 ,3 ,7).
le 7 avec ( 13,14,18)..
voilà .
Merci

job75 · 16 Avril 2017

Re,

Pas clair, listez les couples.

A+

vincent noah · 16 Avril 2017

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 · 16 Avril 2017

Re,

Bah entre le post #17 et le post #19 ce ne sont plus les mêmes couples !!!

Et que signifie le etc.. à la fin du post #19 ???

A+

job75 · 16 Avril 2017

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 · 16 Avril 2017

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+

job75 · 17 Avril 2017

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.

job75 · 17 Avril 2017

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+

vincent noah · 17 Avril 2017

re ,
Oui çà

marche ! bien jouer! job75
juste une petite question combien de couple je peux ajouter ?
suis-je limité ?

A+

job75 · 17 Avril 2017

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+

vincent noah · 17 Avril 2017

ok merci beaucoup pour tout !

A+

vincent noah · 17 Avril 2017

re, job75

une dernière question : si je veux inverser le code et ne garder que les couples souhaité
peux-tu m'indiquer la manip stp ?
A++

Dranreb · 17 Avril 2017

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

job75 · 17 Avril 2017

Re,

vincent noah à dit:
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.

condition VBA

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums