Kombinationen ausgeben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi,
ich komme bei 6 Kugeln in 4 Schalen auf folgende Kombinationen:
Das sind aber nur 54, und bei immerhin 44 davon ist eine Schale leer.
6 0 0 0
5 1 0 0
4 1 1 0
3 2 0 1
3 2 1 0
1 4 1 0
0 3 2 1
0 3 1 2
2 2 2 0
1 3 1 1
0 2 3 1
0 2 2 2
2 0 3 1
1 1 3 1
1 0 3 2
0 1 1 4
3 1 1 1
2 2 1 1
1 1 2 2
1 1 1 3
2 1 2 1
1 2 1 2
1 1 0 4
5 0 1 0
0 1 3 2
0 1 2 3
3 1 2 0
1 2 2 1
1 2 0 3
0 2 1 3
2 0 2 2
0 1 0 5
4 2 0 0
1 3 2 0
3 0 2 1
2 3 1 0
4 0 2 0
2 1 3 0
2 1 1 2
2 2 0 2
0 1 4 1
0 0 2 4
0 0 0 6
5 0 0 1
4 1 0 1
2 3 0 1
1 2 3 0
1 0 1 4
1 0 0 5
1 0 2 3
0 2 0 4
0 0 1 5
4 0 1 1
1 3 0 2
Ich hab das ganze mit Excel Bordmitteln gelöst, Datei hänge ich an. Geht bis 10 Kugeln in 10 Schalen, ich glaub dadrüber wirds auch zuviel. Da auf VBA verzichtet werden sollte, habe ich das ganze etwas größer anlegen müssen. Die Formeln so weit wie nötig nach unten ziehen (gekürtzt für den Upload), ein paar Tausend Zeilen für den Anfang. Die Kombinationen wiederholen sich, per Formel zähle ich ob es die Kombination schon gab (so bilde ich die Einzigartig-Summe).
Links sind alle Kombinationen für eindeutige Kugeln angebeben und ausgerechnet (ergibt 192 zu 120 Kombinationen), daraus rechne ich rechts die Anzahl Kugeln pro Schale.
https://www.herber.de/bbs/user/82896.xlsx
Grüße,
Klaus M.vdT.

Sub x() Dim a%, b%, c%, d%, e%, f%, ar(1 To 4), i% Dim objDic As Object Set objDic = CreateObject("scripting.dictionary") For a = 1 To 4 For b = 1 To 4 For c = 1 To 4 For d = 1 To 4 For e = 1 To 4 For f = 1 To 4 For i = 1 To 4: ar(i) = 0: Next ar(a) = ar(a) + 1 ar(b) = ar(b) + 1 ar(c) = ar(c) + 1 ar(d) = ar(d) + 1 ar(e) = ar(e) + 1 ar(f) = ar(f) + 1 objDic(Join(ar, "-")) = 0 Next Next Next Next Next Next With Cells(1, 1).Resize(objDic.Count) .Value = WorksheetFunction.Transpose(objDic.Keys) End With objDic.RemoveAll Set objDic = Nothing End Sub

Nochmals Hallo,
wenn Du das unabhängig von n und k brauchst lässt sich das auch machen.
Dieses hier - aus einer 'Sammlung' kopiert ;-) - erstellt z.B. die Liste der gezogenen Topf-Nummern in Spalte A.
Um daraus die Anzahl der Kugel je Topf zu erhalten müsste man den Code anpassen oder aber danach einfach noch Excel-Formeln benutzen:
B1: =LÄNGE($A1)-LÄNGE(WECHSELN($A1;SPALTE(A1);""))
nach B1:E84 kopieren.
HTH, Bernd
--
Option Explicit
Private Const strDigits As String = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Sub KombinationenMitZuruecklegenString(ByVal n As Integer, ByVal k As Integer)
Dim ar() As String, lngSize As Long, s As String, i As Long
lngSize = WorksheetFunction.Combin(n - 1 + k, k)
ReDim ar(1 To lngSize, 1 To 1)
s = String(k, Left(strDigits, 1))
ar(1, 1) = s
For i = 2 To lngSize
ar(i, 1) = strIncRisingOrEqual(s, n, k, k)
Next
Range("A1").Resize(lngSize) = ar
End Sub

Function strIncRisingOrEqual(ByRef s As String, ByVal n As Integer, ByVal k As Integer, ByVal  _
intSpalte As Integer) As String
Dim intVal As Integer, i As Integer
intVal = InStr(1, strDigits, Mid(s, intSpalte, 1), vbTextCompare)
If intVal

Sub Main()
Dim n As Integer, k As Integer, t As Single
n = 4
k = 6
t = Timer
KombinationenMitZuruecklegenString n, k
Debug.Print "String", Timer - t
End Sub

Sub Kugel_legen() Dim iSchalen As Integer, iKugeln As Integer Dim i, j, objErg As Object, iTest As Long, strTest As String, strKombi As String Set objErg = CreateObject("Scripting.Dictionary") iSchalen = 4 iKugeln = 6 For i = iKugeln To iKugeln * 10 ^ (iSchalen - 1) iTest = 0 strKombi = "" strTest = Format(i, String(iSchalen, "0")) 'Quersumme For j = 1 To Len(strTest) strKombi = strKombi & Mid(strTest, j, 1) & "-" iTest = iTest + Mid(strTest, j, 1) * 1 Next If iTest = iKugeln Then objErg(strTest) = Left(strKombi, 2 * iSchalen - 1) End If Next With Sheets(1) .Columns(1).Clear .Cells(1, 1).Resize(objErg.Count) = WorksheetFunction.Transpose(objErg.items) End With End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread