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
|