Sub WuerfelmalmitRosenthal2()
Dim AnzahlWürfel As Integer, Augen As Long, zae1 As Long, Kombi As Long
Dim WürfelArray() As Variant
Dim i As Long
Dim wurfOK As Boolean
AnzahlWürfel = Application.InputBox("Würfelanzahl eingeben.", "Nicht Kombination :)", , , , _
, 1)
If AnzahlWürfel = False Or AnzahlWürfel > 6 Then Exit Sub
Kombi = 6 ^ AnzahlWürfel
ReDim WürfelArray(1 To Kombi, 1 To 1)
For Augen = String(AnzahlWürfel, "1") To String(AnzahlWürfel, "6")
If Not Augen Like "*[7-9,0]*" Then
wurfOK = True
For i = AnzahlWürfel - 1 To 1 Step -1
If (Augen \ 10 ^ i) Mod 10 > (Augen \ 10 ^ (i - 1)) Mod 10 Then
wurfOK = False
End If
Next
If wurfOK Then
zae1 = zae1 + 1
WürfelArray(zae1, 1) = Augen
End If
End If
Next Augen
Range(Cells(1, 2), Cells(Kombi, 2)) = WürfelArray
End Sub
Sub test()
Dim l As Long, n As Integer, objDict As Object, arrTmp(), i As Integer, x
Set objDict = CreateObject("scripting.Dictionary")
n = Application.InputBox("Wieviele Würfel ?", , , , , , , 1)
If n = False Or n > 6 Then Exit Sub
ReDim arrTmp(n - 1)
Set objDict = CreateObject("scripting.Dictionary")
For l = String(n, "1") To String(n, "6")
If Not l Like "*[7-9,0]*" Then
For i = 1 To n
arrTmp(i - 1) = Mid(l, i, 1)
Next
prcSort arrTmp
x = Join(arrTmp, "")
objDict(x) = 0
End If
Next
Range("A1").Resize(objDict.Count) = WorksheetFunction.Transpose(objDict.keys)
End Sub
Sub prcSort(arr)
Dim sTmp, i, j
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
sTmp = arr(i)
arr(i) = arr(j)
arr(j) = sTmp
End If
Next
Next
End Sub
Option Explicit
Option Base 0 'Indizierung soll bei 0 beginnen - Standard, Angabe daher nicht unbedingt _
notwendig
'Listet alle möglichen Kombinationen von unabhängigen Ziehungen/Würfen in einem Tabellenblatt _
auf
'Wahlweise MIT oder OHNE allen Permutationen (also 1-2-3 UND 1-3-2 UND 3-2-1) einer Kombination
'Lösungsweg per rekursiven Aufruf der Prozedur mit inkrementiertem Index (intWert)
'20.08.2010, NoNet - www.excelei.de
Public lngZ As Long
Const intAnzZ = 4 'Anzahl der parallelen Ziehungen/Würfe
Const intAnzW = 6 'Anzahl mögliche Werte pro Ziehung/Wurf
Const bolPermutationen = False 'FALSE = OHNE, TRUE = MIT Permutationen
Sub KombinationenStarten()
Dim intZiehung()
ReDim intZiehung(intAnzZ - 1)
lngZ = 0
Range("A1").Resize(intAnzW ^ intAnzZ, intAnzZ).ClearContents
WerteZiehen intZiehung, 0
End Sub
Sub WerteZiehen(intZiehung, intWert As Integer)
Dim intT As Integer
For intT = 1 To intAnzW
intZiehung(intWert) = intT
If intWert = intZiehung(IIf(intWert > 0, intWert - _
1, 0)) Then
Call WerteZiehen(intZiehung, intWert + 1)
End If
Else
If bolPermutationen Or intZiehung(intWert) >= intZiehung(IIf(intWert > 0, intWert - _
1, 0)) Then
lngZ = lngZ + 1
Cells(lngZ, 1).Resize(, intAnzZ) = intZiehung
End If
End If
Next
End Sub