Guten Abend zusammen,

ich habe bereits vor über einem Monat versucht eine Antwort bzgl. meiner Frage zu bekommen, war leider jedoch erfolglos. Nun versuche ich es erneut und freue mich auf eure Ideen :)

Grob gesagt geht es um einen Vektor, wessen Einträge in ihrer Reihenfolge so verändert werden, dass ich alle Anordnungsmöglichkeiten erhalte. Dies macht mein unten aufgeführter Code bereits, jedoch generiert er auch "doppelte" Möglichkeiten, da gleiche Ziffern miteinander vertauscht werden, was für mich keinen neuen Fall darstellt.

Stand:

1. Ein Vektor mit einer variablen Länge (in meinem Code Arr genannt)

2. Eine gewisse Anzahl an Stellen dieses Vektors, welcher mit 1en oder 2en gefüllt werden darf (in meinem Code A_NmaxVal genannt)

3. Mein Code generiert alle Anordnungsmöglichkeiten dieses Vektors (Vertauschen der Zeichenreihenfolge)

Problem:

Der Permutationscode (Function permutation) generiert auch doppelte Möglichkeiten (vertauscht z. B. eine 0 mit einer 0 im Vektor)

-> Je nach Fall (Größe von Arr oder A_NmaxVal) dauert es sehr lange bis alle Möglichkeiten gefunden werden

Anschließend lösche ich alle doppelten Möglichkeiten (dieser Programmcode wird in meinem unten gezeigten Codeschnipsel nicht ausgeführt).

Ziel:

Generierung von allen unterschiedlichen Möglichkeiten ohne doppelte Möglichkeiten zu berechnen um Rechenzeit zu sparen

Sub s_Array_erstellen()
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'Die Laenge dieses Arrays ist variabel!
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Arr = Array(1, 2, 3, 4, 5)
    s_Faelle_erstellen (Arr)
End Sub

Sub s_Faelle_erstellen(b)
     
    'Zahlen (diese sind natuerlich nur fiktiv, in Realitaet sind es Verweise auf bestimmte Namen
    strVal1 = "=1"
    strVal2 = "=2"
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'Beliebig waehlbare max. Anzahl an befuellten Eintraegen in Matrix
    '(muss natuerlich kleiner als die Anzahl der Arrayeintraege sein)
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    A_NmaxVal = 3
     
    'Array überschreiben
    a = b
    'Array auf Null setzen
    For i = 0 To UBound(a)
        a(i) = 0
    Next
    'Matrizen erzeugen für alle Fälle
    For j = 0 To A_NmaxVal - 1
        'Für alle bisher vorhandenen Werte in der Matrix
        For l = 0 To j
            'Wert in Matrix ersetzen
            a(l) = strVal1
            'Permutation durchführen
            Call permutation(a, 0)
        Next
        For m = 0 To j
            'Wert in Matrix ersetzen
            a(m) = strVal2
            'Permutation durchführen
            Call permutation(a, 0)
        Next
        '_______________________________________
        'Finden und Löschen von doppelten Werten
'        s_Werte_zusammenfassen (a)
'        Call s_DoppelteZeilenLöschen(a)
'        Call s_LetzteSpalteLoeschen
        '_______________________________________
    Next
     
End Sub
 
Function permutation(ByVal a, k)
    If k = UBound(a) Then
        Zeile = Cells(65536, 1).End(xlUp).Row
        If Cells(1, 1) <> "" Then Zeile = Zeile + 1
        ActiveSheet.Range(Cells(Zeile, 1), Cells(Zeile, UBound(a) + 1)).FormulaArray = a
        Exit Function
    Else
        For i = k To UBound(a)
            x = a(i)
            a(i) = a(k)
            a(k) = x
            Call permutation(a, k + 1)
        Next
    End If
End Function

Vielen Dank bereits im Voraus.

LG Daniel