Permutations d'une chaine de chiffres

bonjour

existe t il une fonction en vba qui permettre de calculer toutes les permutations d'une chaine de chiffres

j'ai écri le bout de code suivant qui marche a tout les coups mais c'est un peu lourd

ex :pour N = 1123 j'obtiens bien 12 possibilités de permutations

soit 1123 1132 1213 ...etc

Option Base 1
Sub plus_Bouton1_Cliquer()
Dim t() As Variant
Dim nombre As String
nombre = InputBox("saisir une chaine numerique")

c = 1
j = 0
Do
ReDim Preserve t(1 To c)
If InStr(classe(nombre), j) = 0 Then
 t(c) = j
 c = c + 1
End If
j = j + 1
Loop Until j = 9

For i = classe(Val(nombre)) To StrReverse(classe(Val(nombre)))
n = 0
 For k = 1 To UBound(t)
  If InStr(i, t(k)) = 0 Then
   n = n + 1
  End If
 Next
 If n = UBound(t) Then
   If InStr(w, i) = 0 Then

       If Val(classe(CStr(i))) = classe(Val(nombre)) Then
         w = w & " " & i
         compteur = compteur + 1
       End If
   End If
 End If
Next
msgbox w & Chr(10) & "il apparait: " & compteur & " élements dans ce resultat"    ' sur cette ligne le resultat

End Sub

Function nbr_fois(n As Integer) As Integer

w = ""
For i = 1 To Len(n)
p = 0
   If InStr(w, Mid(n, i, 1)) = 0 Then
     For j = i To Len(n)
       If Mid(n, i, 1) = Mid(n, j, 1) Then
       p = p + 1
       End If
     Next
       q = q & Chr(10) & " la valeur  " & Mid(n, i, 1) & " apparait  " & p & " fois"
         w = w & Mid(n, i, 1)
   End If
Next
   nbr_fois = q

End Function

Function classe(n As String) As String
For i = 1 To Len(n) - 1
 For j = i + 1 To Len(n)
  If Val(Mid(n, i, 1)) > Val(Mid(n, j, 1)) Then
   a = Val(Mid(n, i, 1))
   b = Val(Mid(n, j, 1))
   Mid(n, j, 1) = a
   Mid(n, i, 1) = b
  End If
 Next
Next
classe = n
End Function

Merci pour vos réponses

me suis avancé un peu vie car dès que la chaine contient un "0" il n'est meme pas pri en compte ...bon je vais revoir tout ca

Bonjour,

C'était un sympathique casse-tête

Puisque tu utilises apparemment le pack de fonctions du site, voici une solution qui semble fonctionner et qui utilise les fonctions du pack array_add et array_duplicates_delete (n'oublie pas d'ajouter la référence dans ton classeur).

Sub exemple()

    c = "081123" 'Chaîne d'exemple
    n = Len(c)
    t = Array(c)

    For i = 1 To n 'Caractère 1
        nb = UBound(t)
        For ii = 1 To n 'Caractère 2
            For b = 0 To nb
                If i <> ii Then
                    c1 = Mid(t(b), i, 1)
                    c2 = Mid(t(b), ii, 1)
                    If c1 <> c2 Then
                        ci = IIf(i > ii, c1, c2) 'Position 1
                        ca = IIf(i < ii, c1, c2) 'Position 2
                        mi = Application.Min(i, ii)
                        ma = Application.Max(i, ii)
                        array_add t, Mid(t(b), 1, mi - 1) & ci & Mid(t(b), mi + 1, ma - mi - 1) & ca & Mid(t(b), ma + 1, n - ma)
                    End If
                End If
            Next
        Next
        array_duplicates_delete t
    Next

    'array_debug t 'Décommente pour afficher le (début du) tableau

    MsgBox "Nombre = " & UBound(t) + 1

End Sub

Cordialement,

Un grand merci Sébastien, je vais regarder ça de pré et voir plus en détail les fonctions du pack, merci !