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.

Dranreb · 18 Avril 2017

Pour ma part j'ai pu faire tourner ça, qui ne contient pas les combinaisons comportant à la fois 1 et 5 ni 7 et 9

VB:

Option Explicit
Dim TabInterdits() As Boolean

Sub Combinaisons()
Dim M&, N&, O&, P&, Q&, TR(1 To 50000, 1 To 5), L&
ReDim TabInterdits(1 To NumVS(19, 20))
TabInterdits(NumVS(1, 5)) = True
TabInterdits(NumVS(7, 9)) = True
For M = 1 To 16
   For N = M + 1 To 17
      For O = N + 1 To 18
         For P = O + 1 To 19
            For Q = P + 1 To 20
               If AssocValide(M, N, O, P, Q) Then
                  L = L + 1: TR(L, 1) = M: TR(L, 2) = N: TR(L, 3) = O: TR(L, 4) = P: TR(L, 5) = Q
                  End If: Next Q, P, O, N, M
ActiveSheet.[A1:E50000].Value = TR
End Sub

Function AssocValide(ParamArray TN()) As Boolean
Dim P1&, P2&
For P1 = 0 To UBound(TN) - 1
   For P2 = P1 + 1 To UBound(TN)
      If TabInterdits(NumVS(TN(P1), TN(P2))) Then Exit Function
      Next P2, P1
AssocValide = True
End Function

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

vincent noah · 18 Avril 2017

re, Merci job75 . c'est parfait !
re Dranreb, merci pour t'as proposition de code mais je vais rester sur les propositions de job75 que je vais tenter de croiser pour avoir dans le même code: les couples à exclure et les couples à garder ça sera plus pratique je pense .
et c'est pas simple 😡 donc j'ai pas fini avant un moment je pense 😱.

A+

job75 · 18 Avril 2017

Re,

vincent noah à dit:
je vais tenter de croiser pour avoir dans le même code: les couples à exclure et les couples à garder

Il faut alors 2 Dictionary et 2 fonctions Couple.

Ici sont gardés les couples listés non exclus :

Code:

Dim dicoexclu As Object, dicogarder As Object 'mémorise les variables

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

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

Sub Combinaisons()
Dim nmax%, exclu, garder, Ncombi&, rc&, tablo$(), m%, n%, o%, p%, q%, g1, g2, g3, g4, 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
garder = Array("1 7", "2 9", "7 10") 'liste modifiable
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dicoexclu = CreateObject("Scripting.Dictionary")
Set dicogarder = CreateObject("Scripting.Dictionary")
For m = 0 To UBound(exclu): dicoexclu(exclu(m)) = "": Next
For m = 0 To UBound(garder): dicogarder(garder(m)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    If CoupleExclu(n, m) Then GoTo 1
    g1 = CoupleGarder(n, m)
    For o = n + 1 To nmax - 2
      If CoupleExclu(o, m, n) Then GoTo 2
      If g1 Then g2 = True Else g2 = CoupleGarder(o, m, n)
      For p = o + 1 To nmax - 1
        If CoupleExclu(p, m, n, o) Then GoTo 3
        If g2 Then g3 = True Else g3 = CoupleGarder(p, m, n, o)
        For q = p + 1 To nmax
          If CoupleExclu(q, m, n, o, p) Then GoTo 4
          If g3 Then g4 = True Else g4 = CoupleGarder(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
4       Next q
3     Next p
2   Next o
1 Next n
Next 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 (5).

Edit : et bien sûr dans la foulée le fichier (6) parallèle aux fichiers (2) et (4).

A+

vincent noah · 18 Avril 2017

re, job75 ,
ton dernier code poste 30 ne fonctionne pas je viens de remarquer

VB:

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%, 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") '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

je retrouve des couples que ne veux pas exemple : 1,3😵😵

A+

job75 · 18 Avril 2017

Re,

Oui ma solution (5) ne va pas, et je ne vois pas comment faire.

Bonne nuit.

vincent noah · 19 Avril 2017

oui,
je vais essayer de garder les solutions poste 23 voir si je peux les modifier .

bonne nuit également

job75 · 19 Avril 2017

Re,

Bah j'avais fait une erreur stupide en écrivant :

For m = 0 To UBound(exclu): dicogarder(exclu(m)) = "": Next

Je corrige le fichier (5), maintenant il fonctionne.

Re-bonne nuit.

vincent noah · 19 Avril 2017

re ,
oui effectivement ça fonctionne maintenant ( j'était loin de trouver cette erreur😕).
Merci pour tout ces codes je n'aurais pas avancé de beaucoup sans ton aide .🙂.

A++

vincent noah · 17 Mai 2017

bonjours à tous ,
re job ,
ci-joint le ficher exemple avec des couples et des triples à exclure ( ps: pas de fonction garde pour l'instant) .
pouvez-vous m'indiqué à combien de couples et de triples je-suis limité ?

Merci encore de votre aides
A+

job75 · 17 Mai 2017

Bonjour vincent noah,

Code:

Dim dicoexclu1 As Object, dicoexclu2 As Object 'mémorise les variables

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

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

Sub Combinaisons()
Dim nmax%, exclu1, exclu2, Ncombi&, rc&, tablo$(), m%, n%, o%, p%, q%, lig&, col%
nmax = 20 'modifiable
exclu1 = [D1].CurrentRegion.Resize(, 2) 'couples
exclu2 = [L1].CurrentRegion.Resize(, 3) 'triples
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dicoexclu1 = CreateObject("Scripting.Dictionary")
Set dicoexclu2 = CreateObject("Scripting.Dictionary")
For m = 1 To UBound(exclu1): dicoexclu1(exclu1(m, 1) & " " & exclu1(m, 2)) = "": Next
For m = 1 To UBound(exclu2): dicoexclu2(exclu2(m, 1) & " " & exclu2(m, 2) & " " & exclu2(m, 3)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    If CoupleExclu(n, m) Then GoTo 1
    For o = n + 1 To nmax - 2
      If CoupleExclu(o, m, n) Or TripleExclu(o, m, n) Then GoTo 2
      For p = o + 1 To nmax - 1
        If CoupleExclu(p, m, n, o) Or TripleExclu(p, m, n, o) Then GoTo 3
        For q = p + 1 To nmax
          If CoupleExclu(q, m, n, o, p) Or TripleExclu(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
[P1].CurrentRegion.ClearContents 'RAZ
If lig Or col Then [P1].Resize(IIf(col, rc, lig), col + 1) = tablo
Columns("P").Resize(, col + 1).AutoFit 'ajustement largeur
End Sub

Fichier joint.

vincent noah à dit:
pouvez-vous m'indiqué à combien de couples et de triples je-suis limité ?

Pour les exclusions : 190 et 1140, je vous laisse trouver comment on obtient ces chiffres....

A+

vincent noah · 17 Mai 2017

re, job75,
en réponse à la devinette je dirais (5 parmi 20) et (3 parmi 20) mais j'ajouterais -1 donc 189 pour éviter un résultat vide :
non quand j'ai posé cette question je pensé à la limite que la macro peut prendre en charge avant de planter ?

un grand Merci pour tout.
A+

job75 · 17 Mai 2017

vincent noah à dit:
non quand j'ai posé cette question je pensé à la limite que la macro peut prendre en charge avant de planter ?

Vous voulez dire si l'on augmente nmax ?

La création de tableau est limitée par la quantité de mémoire disponible.

Chez moi j'ai pu créer sans bug un tableau (vide) de 1048576 lignes et 507 colonnes (type String) ou 126 colonnes (type Variant) :

Code:

Sub LimiteTableauString()
Dim tablo$(), rc&, col%
rc = Rows.Count
col = 507
ReDim tablo(1 To rc, 1 To col)
End Sub

Sub LimiteTableauVariant()
Dim tablo(), rc&, col%
rc = Rows.Count
col = 126
ReDim tablo(1 To rc, 1 To col)
End Sub

Cela laisse de la marge !

Avec la macro Combinaisons il est probable que vous quitterez Excel par le Gestionnaire des tâches bien avant le plantage.

A+

job75 · 17 Mai 2017

Re,

Plus prosaïquement j'ai créé dans la feuille le tableau A1:Z1048576.

En entrant dans les 27 262 976 cellules la chaîne "10 11 12 13 14".

Cela donne quand même un fichier de 76 Mo...

Avec l'instruction tablo = [A1].CurrentRegion le tableau VBA se crée sans problème.

Donc on doit pouvoir traiter le cas nmax = 81 ou 82.

A+

vincent noah · 17 Mai 2017

re, oui je confirme ,

juste j'essayer d'introduire la fonction gardercouple en me servant de t'es précédant code j'arrive difficilement à ça mais sans succès 😡 :

VB:

Option Explicit
Dim dicoexclu1 As Object, dicoexclu2 As Object, dicogarder As Object 'mémorise les variables
Function CoupleGarder(x%, a%, Optional b%, Optional c%, Optional d%) As Boolean
If dicogarder.exists(a & " " & x) Then CoupleGarder = True: Exit Function
If b = 0 Then Exit Function Else If dicogarder.exists(b & " " & x) Then CoupleGarder = True: Exit Function
If c = 0 Then Exit Function Else If dicogarder.exists(c & " " & x) Then CoupleGarder = True: Exit Function
If d Then If dicogarder.exists(d & " " & x) Then CoupleGarder = True
End Function

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

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

Sub Combinaisonselimination()
Dim nmax%, exclu1, exclu2, garder, Ncombi&, rc&, tablo$(), m%, n%, o%, p%, q%, g1, g2, g3, g4, lig&, col%
nmax = 25 'modifiable
lig = 1
exclu1 = [I1].CurrentRegion.Resize(, 2) 'couples
exclu2 = [L1].CurrentRegion.Resize(, 3) 'triples
garder = Array("1 13")
Ncombi = Application.Combin(nmax, 5) 'nombre de combinaisons
rc = Rows.Count
ReDim tablo(1 To rc, 0 To Int(Ncombi / rc))
Set dicoexclu1 = CreateObject("Scripting.Dictionary")
Set dicoexclu2 = CreateObject("Scripting.Dictionary")
Set dicogarder = CreateObject("Scripting.Dictionary")
For m = 1 To UBound(exclu1): dicoexclu1(exclu1(m, 1) & " " & exclu1(m, 2)) = "": Next
For m = 1 To UBound(exclu2): dicoexclu2(exclu2(m, 1) & " " & exclu2(m, 2) & " " & exclu2(m, 3)) = "": Next
For m = 0 To UBound(garder): dicogarder(garder(m)) = "": Next
For m = 1 To nmax - 4
  For n = m + 1 To nmax - 3
    If CoupleExclu(n, m) Then GoTo 1
     g1 = CoupleGarder(n, m)
    For o = n + 1 To nmax - 2
        If g1 Then g2 = True Else g2 = CoupleGarder(o, m, n)
      If CoupleExclu(o, m, n) Or TripleExclu(o, m, n) Then GoTo 2
      For p = o + 1 To nmax - 1
       If g2 Then g3 = True Else g3 = CoupleGarder(p, m, n, o)
        If CoupleExclu(p, m, n, o) Or TripleExclu(p, m, n, o) Then GoTo 3
        For q = p + 1 To nmax
         If g3 Then g4 = True Else g4 = CoupleGarder(q, m, n, o, p)

          If CoupleExclu(q, m, n, o, p) Or TripleExclu(q, m, n, o, p) Then GoTo 4
          If g4 Then
         
         
          tablo(lig, col) = m & " " & n & " " & o & " " & p & " " & q
          lig = lig + 1
          If lig = rc Then lig = 0: col = col + 1

            End If
          End If

4       Next q
3     Next p
2   Next o
1 Next n
Next m
[P1].CurrentRegion.ClearContents 'RAZ
If lig Or col Then [P1].Resize(IIf(col, rc, lig), col + 1) = tablo
Columns("P").Resize(, col + 1).AutoFit 'ajustement largeur
End Sub

peux-tu jeter un coup d’œil stp.
A+

job75 · 17 Mai 2017

Re,

Ce n'est pas mal du tout mais :

- vous n'avez pas respecté l'ordre des tests pour g2 g3 g4

- lig = 1 au début est à supprimer et lig = lig + 1 est à placer 2 lignes au-dessus

- [Edit] il y a un End If en trop.

A+

condition VBA

vincent noah

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

vincent noah

XLDnaute Junior

job75

XLDnaute Barbatruc

Pièces jointes

vincent noah

XLDnaute Junior

job75

XLDnaute Barbatruc

vincent noah

XLDnaute Junior

job75

XLDnaute Barbatruc

vincent noah

XLDnaute Junior

vincent noah

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

vincent noah

XLDnaute Junior

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

vincent noah

XLDnaute Junior

job75

XLDnaute Barbatruc

Discussions similaires

condition VBA

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency