Trouver les combinaisons, besoin d'aide !

[Stralcops]

Bonjour,
j'aimerai faire un tableau excel qui me donnerai toutes les combinaisons (ou arrangement il me semble) dans l'ordre sachant qu'il faut que je trouve un code à 8 chiffre avec 6 valeurs différentes. J’espère trouver de l'aide ! merci !

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Bonsoir Stralcops, bienvenue sur XLD,

Voyez le fichier joint et cette macro :

Sub Arrangements()
Dim dur#, dif As Byte, nlig&, col%, t(), dico As Object
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte
Dim f As Byte, g As Byte, h As Byte, arr, i As Byte, n&, total&
dur = Now
dif = 6 'nombre de chiffres différents
nlig = 1000000
col = 0
ReDim t(nlig - 1, 0) 'base 0
Set dico = CreateObject("Scripting.Dictionary")
Rows("2:" & Rows.Count).ClearContents  'RAZ
For a = 0 To 9
  For b = 0 To 9
    For c = 0 To 9
      For d = 0 To 9
        For e = 0 To 9
          For f = 0 To 9
            For g = 0 To 9
              For h = 0 To 9
                arr = Array(a, b, c, d, e, f, g, h)
                dico.RemoveAll
                For i = 0 To 7
                  dico(arr(i)) = ""
                  If dico.Count = dif Then
                    If n = nlig Then
                      [A2].Offset(, col).Resize(n) = t
                      ReDim t(n - 1, 0) 'RAZ
                      total = total + n
                      n = 0: col = col + 1
                    End If
                    t(n, 0) = Join(arr)
                    n = n + 1
                    Exit For
                  End If
Next i, h, g, f, e, d, c, b, a
If n Then [A2].Offset(, col).Resize(n) = t
MsgBox total + n & " arrangements" & vbLf & _
  "Durée " & Format(Now - dur, "hh:mm:ss")
End Sub

Nota 1 : j'ai supposé qu'il faut au moins 6 chiffres différents.

S'il faut exactement 6 chiffres différents dites-le, je modifierai la macro.

Nota 2 : il faut vous armer de patience, il y a beaucoup d'arrangements !!!

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re,

J'ai lancé la macro, après avoir listé 22 millions d'arrangements j'ai eu le message "Mémoire insuffisante etc".

Il faudrait un ordi plus puissant.

Au total on voit qu'il y a environ 60 millions d'arrangements.

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re,

Si l'on arrivait à lister les 60 Mio d'arrangements le fichier pèserait environ 500 Mio d'octets

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re,

Avec des arrangements de 7 chiffres dont au moins 6 différents pas de problème :

Sub Arrangements()
Dim dur#, dif As Byte, nlig&, col%, t(), dico As Object
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte
Dim f As Byte, g As Byte, arr, i As Byte, n&, total&
dur = Now
dif = 6 'nombre de chiffres différents
nlig = 1000000
col = 0
ReDim t(nlig - 1, 0) 'base 0
Set dico = CreateObject("Scripting.Dictionary")
Rows("2:" & Rows.Count).ClearContents  'RAZ
For a = 0 To 9
  For b = 0 To 9
    For c = 0 To 9
      For d = 0 To 9
        For e = 0 To 9
          For f = 0 To 9
            For g = 0 To 9
              arr = Array(a, b, c, d, e, f, g)
              dico.RemoveAll
              For i = 0 To 6
                dico(arr(i)) = ""
                If dico.Count = dif Then
                  If n = nlig Then
                    [A2].Offset(, col).Resize(n) = t
                    ReDim t(n - 1, 0) 'RAZ
                    total = total + n
                    n = 0: col = col + 1
                  End If
                  t(n, 0) = Join(arr)
                  n = n + 1
                  Exit For
                End If
Next i, g, f, e, d, c, b, a
If n Then [A2].Offset(, col).Resize(n) = t
MsgBox total + n & " arrangements" & vbLf & _
  "Durée " & Format(Now - dur, "hh:mm:ss")
End Sub

Fichier (2).

3 780 000 arrangements listés chez moi en 4 minutes 31 secondes.

Le fichier pèse alors 36 Mo.

Bonne fin de soirée.

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re, pour finir,

Avec 7 chiffres dont au moins 5 différents pas de problème non plus.

8 013 600 arrangements listés en 5 minutes 13 secondes.

Le fichier pèse alors 64 Mo.

Bonne nuit.

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Bonjour Stralcops, le forum,

J'ai fait tourner la macro du fichier (1) jusqu'au bout en n'affichant pas les arrangements.

J'ai obtenu un total de 58 968 000 arrangements en 30 minutes 5 secondes.

Bonne journée.

 

[Modeste geedee]

Re : Trouver les combinaisons, besoin d'aide !

Bonsour®

Bonjour,
j'aimerai faire un tableau excel qui me donnerai toutes les combinaisons (ou arrangement il me semble) dans l'ordre sachant qu'il faut que je trouve un code à 8 chiffre avec 6 valeurs différentes. J’espère trouver de l'aide ! merci !

Quel intérêt de générer toutes les combinaisons possibles ????
comme le fait remarquer JOB75 :
- le volume de données est très important,
- le temps de génération non négligeable
- la taille du classeur conséquente ...
- la consultation visuelle effective et continue de chaque code à raison de 10 codes par secondes te prendra quelques ... heures de ta vie...

la recherche d'un code particulier pour comparaison sera également dévoreur de temps !!

plutôt un générateur unitaire très simple et rapide
la probabilité de doublon est de l'ordre de 1 sur + de 4 millions de tirage

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re, Bonjour Modeste geedee,

Il est quand même possible de lister les 58 968 000 arrangements pour 8 chiffres.

Voyez le fichier joint et cette macro :

Sub Arrangements()
Dim dur#, dif As Byte, dossier$, col%, t(), dico As Object
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte
Dim f As Byte, g As Byte, h As Byte, arr, i As Byte, n&, total&, nom$
dur = Now
dif = 6 'nombre de chiffres différents
dossier = ThisWorkbook.Path & "\Arrangements\"
If Dir(dossier, vbDirectory) = "" Then MkDir dossier 'création du dossier
col = 1
ReDim t(1 To 50000, 1 To 20) 'base 1
Set dico = CreateObject("Scripting.Dictionary")
Feuil1.[B1:C1] = ""
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For a = 0 To 9
  For b = 0 To 9
    For c = 0 To 9
      For d = 0 To 9
        For e = 0 To 9
          For f = 0 To 9
            For g = 0 To 9
              For h = 0 To 9
                arr = Array(a, b, c, d, e, f, g, h)
                dico.RemoveAll
                For i = 0 To 7
                  dico(arr(i)) = ""
                  If dico.Count = dif Then
                    n = n + 1
                    t(n, col) = Join(arr, "")
                    If n = 50000 Then
                      total = total + n
                      n = 0: col = col + 1
                    End If
                    If (total + n) Mod 1000000 = 0 Then
                      col = 1
                      Application.ScreenUpdating = False
                      Workbooks.Add xlWBATWorksheet
                      [A1:T50000].NumberFormat = "@"
                      [A1:T50000].HorizontalAlignment = xlCenter
                      [A1:T50000] = t
                      ReDim t(1 To 50000, 1 To 20) 'RAZ
                      nom = "Mio " & Format(total / 1000000, "00") & " - "
                      Feuil1.[B1] = nom & [A1]
                      ActiveSheet.Name = nom & [A1]
                      ActiveWorkbook.SaveAs dossier & nom & [A1]
                      ActiveWorkbook.Close
                      Feuil1.[C1] = Now - dur
                      Application.ScreenUpdating = True
                      DoEvents
                    End If
                    Exit For
                  End If
Next i, h, g, f, e, d, c, b, a
Application.ScreenUpdating = True
Workbooks.Add xlWBATWorksheet
[A1:T50000].NumberFormat = "@"
[A1:T50000].HorizontalAlignment = xlCenter
[A1:T50000] = t
ActiveSheet.Name = nom & [A1]
ActiveWorkbook.SaveAs dossier & nom & [A1]
ActiveWorkbook.Close
Feuil1.[B1] = total + n: Feuil1.[C1] = Now - dur
Application.ScreenUpdating = True
DoEvents
MsgBox total + n & " arrangements" & vbLf & _
  "Durée " & Format(Now - dur, "hh:mm:ss")
End Sub

Elle crée 60 fichiers contenant chacun 1 Mio d'arrangements et pesant 6,5 Mo.

Chaque fichier est créé chez moi en un peu plus d'une minute, donc il faut au total un peu plus d'une heure.

Nota 1 : on pourrait réduire cette durée de 35% en créant des fichiers textes (.txt).

Nota 2 : la macro peut fonctionner sur Excel 2003 et versions antérieures.

A+

 

[Modeste geedee]

Re : Trouver les combinaisons, besoin d'aide !

Bonsour®

Il est quand même possible de lister les 58 968 000 arrangements pour 8 chiffres.

ça je n'en doute pas
cependant la question reste en suspend :

Quel intérêt de générer toutes les combinaisons possibles ????

pour simplement vérifier si la valeur saisie fait partie des codes correspondant aux critères souhaités ???

un code à 8 chiffre avec 6 valeurs différentes

Le collectionnisme est une activité humaine de collecte d'objet dans un but d'accumulation. Elle peut être, une activité à tendance pathologique : sujet d'étude en psychiatrie

Regarde la pièce jointe 962540
pourquoi alors ne pas pas lister préalablement les entiers long reconnus par Excel afin de savoir si une saisie fait partie des valeurs acceptées ???

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re,

S'il s'agit de vérifier si un code a bien 8 chiffres dont au moins 6 distincts :

Function VerifCode$(code$)
Dim d As Object, i As Byte
If Not code Like "########" Then VerifCode = "???": Exit Function
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 8
  d(Mid(code, i, 1)) = ""
Next
If d.Count < 6 Then VerifCode = d.Count & " distincts"
End Function

La fonction renvoie un texte vide "" si le code est correct et un message dans le cas contraire.

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Bonjour le fil, le forum,

La création de l'objet Dictionary dans la fonction prend beaucoup de temps.

Il est bien plus rapide de le créer une fois pour toutes à l'ouverture du fichier :

Private Sub Workbook_Open()
Set dico = CreateObject("Scripting.Dictionary")
End Sub

et de l'utiliser dans la fonction comme ceci :

Public dico As Object 'mémorise la variable

Function VerifCodeRapide$(code$)
Dim i As Byte
If Not code Like "########" Then VerifCodeRapide = "???": Exit Function
dico.RemoveAll 'RAZ
For i = 1 To 8
  dico(Mid(code, i, 1)) = ""
  If dico.Count = 6 Then Exit Function
Next
VerifCodeRapide = dico.Count & " distincts"
End Function

Voyez le fichier joint de 20000 lignes.

L'exécution des fonctions VerifCode prend chez moi 21 secondes.

Alors que l'exécution des fonctions VerifCodeRapide prend 0,85 seconde.

Bonne journée.

 

[mapomme]

Re : Trouver les combinaisons, besoin d'aide !

Bonjour à tous,

@job75 :

J'ai essayé de voir si on pouvait raccourcir (un peu) le temps d'exécution. Pour cela j'ai tenté de raccourcir la durée par les deux bouts:

1. par exemple, si on a déjà tiré 5 chiffres et que le nombre de chiffres différents est 2, il est inutile de parcourir les boucles suivantes
2. par exemple, si on a déjà tiré 5 chiffres et que le nombre de chiffres différents est 5, on peut parcourir les boucles suivantes sans test au sein de celles-ci (tout arrangement plus grand conviendra)

Le code n'est pas paramétrable! C'est du "au moins 5 différents parmi 7".
J'arrive sur mon vieux micro (qui a quelques pb. depuis Windows 10) à grignoter quelques secondes. Pourrais-tu le tester sur le tien ?

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Bonjour mapomme,

Avec des tests intermédiaires c'est en effet plus rapide.

2 min 48 s chez toi contre 5 min 15 s chez moi.

A+

 

[job75]

Re : Trouver les combinaisons, besoin d'aide !

Re,

Pour 7 chiffres j'ai revu la macro avec des tests intermédiaires et sans Dictionary :

Sub Arrangements()
Dim dur#, dif, nlig&, col%, t()
Dim a, b, c, d, e, f, g, n1, n2, n3, n4, n5, n6
Dim x1$, x2$, x3$, x4$, x5$, x6$, n&, total&
dur = Now
dif = 6 'nombre de chiffres différents
nlig = 1000000
col = 0
ReDim t(nlig - 1, 0) 'base 0
Rows("2:" & Rows.Count).ClearContents  'RAZ
For a = 0 To 9
  For b = 0 To 9
    n1 = 1 - (a <> b)
    x1 = a & b
    If n1 < dif - 5 Then GoTo 1
    For c = 0 To 9
      n2 = n1 - (InStr(x1, c) = 0)
      x2 = x1 & c
      If n2 < dif - 4 Then GoTo 2
      For d = 0 To 9
        n3 = n2 - (InStr(x2, d) = 0)
        x3 = x2 & d
        If n3 < dif - 3 Then GoTo 3
        For e = 0 To 9
          n4 = n3 - (InStr(x3, e) = 0)
          x4 = x3 & e
          If n4 < dif - 2 Then GoTo 4
          For f = 0 To 9
            n5 = n4 - (InStr(x4, f) = 0)
            x5 = x4 & f
            If n5 < dif - 1 Then GoTo 5
            For g = 0 To 9
              n6 = n5 - (InStr(x5, g) = 0)
              x6 = x5 & g
              If n6 < dif Then GoTo 6
              If n = nlig Then
                [A2].Offset(, col).Resize(n) = t
                ReDim t(n - 1, 0) 'RAZ
                total = total + n
                n = 0: col = col + 1
              End If
              t(n, 0) = x6
              n = n + 1
6           Next g
5         Next f
4       Next e
3     Next d
2   Next c
1 Next b
Next a
If n Then [A2].Offset(, col).Resize(n) = t
MsgBox total + n & " arrangements" & vbLf & _
  "Durée " & Format(Now - dur, "hh:mm:ss")
End Sub

Je ne déclare plus les variables As Byte, la durée d'exécution est en fait plus longue !

Fichier joint.

Avec 5 chiffres différents 8 013 600 arrangements durée 1 minute 11 secondes.

Avec 6 chiffres différents 3 780 000 arrangements durée 30 secondes.

A+