AW: Permutation ohne Zurücklegen in Excel..
22.05.2023 20:30:29
Daniel
Hi
weils Spass macht, hier nochmal eine Makrovariante
hier das Hauptmakro, in dem die Werte, die mutiert werden sollen angegeben werden und welche die Permutation startet und dann das Ergebnis ausgibt.
die zu mutierenden Werte werden im String WerteListe mit "|" getrennt angegeben, dh man kann hier nicht nur Zahlen, sondern auch Texte angeben mit mehreren Zeichen angeben, wenn man das wollte.
die Anzahl der Stellen kann man aus der Werteliste wie im Code gezeigt berechnen lassen, oder auch als Wert vorgeben.
die Funktion Transp macht dann aus dem Ergebnis Array ein echtes zweidimensionales Array, das als ganzes in die Tabelle zurückgeschrieben werden kann. Das ist schneller und leistungfähiger (Datenmenge) als das VBA-eigene Worksheetfunction.Transpose.
somit ist das Makro recht schnell und kann dann bis zu 9 Elemente durchmutieren (bei 10 müsste man dann schon die Ausgabe teilen, was aber prinzipiell möglich wäre)
Sub Permutationen_Berechnen()
Dim WerteListe As String
Dim Gesamtergebnis
Dim Zwischenergebnis
Dim Anzahl As Long
WerteListe = "1|2|3|4"
Anzahl = UBound(Split(WerteListe, "|")) + 1
ReDim Zwischenergebnis(1 To Anzahl)
Call Permutation(Gesamtergebnis, Zwischenergebnis, WerteListe, 1)
Gesamtergebnis = Transp(Gesamtergebnis)
Cells(1, 1).Resize(UBound(Gesamtergebnis, 1), UBound(Gesamtergebnis, 2)).Value = Gesamtergebnis
End Sub
Private Sub Permutation(ByRef Gesamtergebnis, ByRef Zwischenergebnis, ByVal Werte As String, ByVal Pos As Long)
Dim x
Dim txt As String
For Each x In Split(Werte, "|")
Zwischenergebnis(Pos) = x
If Pos = UBound(Zwischenergebnis) Then
On Error Resume Next
ReDim Preserve Gesamtergebnis(1 To UBound(Gesamtergebnis) + 1)
If Err > 0 Then ReDim Gesamtergebnis(1 To 1)
On Error GoTo 0
Gesamtergebnis(UBound(Gesamtergebnis)) = Zwischenergebnis
Else
txt = Replace("|" & Werte & "|", "|" & x & "|", "|")
txt = Mid(txt, 2, Len(txt) - 2)
Call Permutation(Gesamtergebnis, Zwischenergebnis, txt, Pos + 1)
End If
Next
End Sub
Private Function Transp(Matrix)
Dim z As Long
Dim s As Long
ReDim Erg(1 To UBound(Matrix), 1 To UBound(Matrix(1)))
For z = 1 To UBound(Erg, 1)
For s = 1 To UBound(Erg, 2)
Erg(z, s) = Matrix(z)(s)
Next
Next
Transp = Erg
End Function
Gruß Daniel