condition VBA

vincent noah

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 :parmi (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 :mad:

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

bonne soirée.
 
Trier par date Trier par votes
Dranreb

Dranreb

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
vincent noah

vincent noah

XLDnaute Junior
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 :mad: donc j'ai pas fini avant un moment je pense :eek:.


A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,
vincent noah à dit:
je vais tenter de croiser pour avoir dans le même code: les couples à exclure et les couples à garder
Cliquez pour agrandir...
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+
 

Pièces jointes

  • Combinaisons(5).xlsm
    28 KB · Affichages: 30
  • Combinaisons(6).xlsm
    27.4 KB · Affichages: 24
Dernière édition:
Vote positif 0 Vote négatif
vincent noah

vincent noah

XLDnaute Junior
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,3o_Oo_O

A+
 
Dernière édition:
Vote positif 0 Vote négatif
vincent noah

vincent noah

XLDnaute Junior
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+
 

Pièces jointes

  • exclucouple-triple.xlsx
    8.9 KB · Affichages: 21
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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é ?
Cliquez pour agrandir...
Pour les exclusions : 190 et 1140, je vous laisse trouver comment on obtient ces chiffres....

A+
 

Pièces jointes

  • exclucouple-triple(1).xlsm
    27.2 KB · Affichages: 32
Vote positif 0 Vote négatif
vincent noah

vincent noah

XLDnaute Junior
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+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
vincent noah à dit:
non quand j'ai posé cette question je pensé à la limite que la macro peut prendre en charge avant de planter ?
Cliquez pour agrandir...
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+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 
Vote positif 0 Vote négatif
vincent noah

vincent noah

XLDnaute Junior
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 :mad: :
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+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
Microsoft 365 Correction du code vba
Réponses
5
Affichages
198
AD95
A
R
  • Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
386
Dranreb
Dranreb
J
  • Question
Microsoft 365 Recherche conditionnelle VBA
2
Réponses
18
Affichages
1 K
sylvanu
sylvanu
Usine à gaz
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
318
Usine à gaz
Usine à gaz
J
  • Résolu(e)
XL 2019 Recherche conditionnelle imbriquées et VBA
Réponses
7
Affichages
525
M12
M12
P
  • Résolu(e)
erreur d'exécution "9" vba sur plage
Réponses
3
Affichages
568
piskely
P
P
  • Question
XL 2019 VBA Erreur d'exécution "9" dans une plage de tableau
Réponses
2
Affichages
339
piskely
P
patricktoulon
  • Résolu(e)
XL 2013 encore un truc chelou
2 3 4
Réponses
45
Affichages
2 K
mapomme
mapomme
C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
334
crazy
C
E
  • Question
XL 2013 vba excel
Réponses
6
Affichages
249
sylvanu
sylvanu

Membres actuellement en ligne

11 membres et 102 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 330
Messages
2 087 339
Membres
103 524
dernier inscrit
Smile1813