Amélioration de mon code VBA avec fonction récursive

Bonjour,

Le but de mon fichier étant de réaliser une combinaison de toutes les possibilités à partir d'une liste.

Pour pouvoir faire cela j'ai imbriqué beaucoup de boucle for les une dans les autres.

J'ai aussi fais une condition afin de déclencher la boucle uniquement si cela est nécessaire (en fonction du nombre d'élément dans la liste de base).

Pour améliorer mon code et pour pouvoir avoir plus d'élément dans ma liste de base, j'aimerais passer par une fonction récursive.

Mais impossible de réaliser cette fonction. Je ne sais pas trop comment m'y prendre.

Pouvez-vous me donner une piste ? et me confirmer que cela est bien possible ?

Je vous remercie par avance pour votre aide.

BD

Bonjour,

à tester,

Sub test()
Dim r(), x As String
Dim rw As Integer, rw2 As Integer, i  As Integer, j As Integer, n As Integer
rw = Cells(Rows.Count, 1).End(xlUp).Row
n = 0
v = Range("A2:A" & rw).Value
For i = LBound(v) To UBound(v)
    x = v(i, 1) & "+"
    For j = LBound(v) To UBound(v)
        If v(j, 1) <> v(i, 1) Then
            x = x & v(j, 1) & "+"
            ReDim Preserve r(n): r(n) = Left(x, Len(x) - 1)
            n = n + 1
        End If
    Next j

    rw2 = Cells(Rows.Count, "M").End(xlUp).Row + 1
    Range("M" & rw2) = i
    rw2 = Cells(Rows.Count, "M").End(xlUp).Row + 1
    Range("M" & rw2).Resize(UBound(r) + 1) = Application.Transpose(r) 'résultat en colonne M
    Erase r
    n = 0
    ReDim Preserve r(n)
Next i
End Sub

Slt dutbas, Slt Isabelle,

j'ai trouvé ce code avec fonction que tu peux adapter à tes besoins.

Sub aTester()
    Dim i As Integer
    Dim A(1 To 5) As Integer
    Dim B As Variant

    For i = 1 To 5
        A(i) = i
    Next i
    MsgBox ListSubsets(A)
End Sub

Function ListSubsets(items As Variant) As String
    Dim CodeVector() As Integer
    Dim i As Integer
    Dim lower As Integer, upper As Integer
    Dim SubList As String
    Dim NewSub As String
    Dim done As Boolean
    Dim OddStep As Boolean

    OddStep = True
    lower = LBound(items)
    upper = UBound(items)

    ReDim CodeVector(lower To upper) 'it starts all 0
    Do Until done
        'Add a new subset according to current contents of CodeVector
        NewSub = ""
        For i = lower To upper
            If CodeVector(i) = 1 Then
                If NewSub = "" Then
                    NewSub = items(i)
                Else
                    NewSub = NewSub & " + " & items(i)
                End If
            End If
        Next i
        SubList = SubList & vbCrLf & NewSub
        'now update code vector
        If OddStep Then
            'just flip first bit
            CodeVector(lower) = 1 - CodeVector(lower)
        Else
            'first locate first 1
            i = lower
            Do While CodeVector(i) <> 1
                i = i + 1
            Loop
            'done if i = upper:
            If i = upper Then
                done = True
            Else
                'if not done then flip the *next* bit:
                i = i + 1
                CodeVector(i) = 1 - CodeVector(i)
            End If
        End If
        OddStep = Not OddStep 'toggles between even and odd steps
    Loop
    ListSubsets = SubList
End Function

Bonne continuation

re,

autre version à tester,

Re,

merci à Isabelle pour cette macro!

pour finir et atteindre le résultat souhaité voici la dernière version

merci à Isabelle pour cette macro! 

merci surtout à Laurent Longre pour cette macro, qui si je me souviens bien, date de l'année 2002

Merci pour vos réponses.

J'ai testé, ça fonctionne mais j'inspecterais vos code plus tard - car la je n'ai pas le temps aujourd'hui - afin de voir comment vous avez procédé. J'aime bien comprendre les choses ...

Je reviendrai vous poser des questions ici si je ne comprend pas une partie du code.

Encore merci

dutbas a écrit :

Je reviendrai vous poser des questions ici si je ne comprend pas une partie du code.

Pas besoin Laurent Longre est toujours en vie

Bonjour dutbas, slt m3ellem1,

@dutbas

est ce que le problème est résolu ?