Mögliche Würfel-Würfe auflisten.

Sub WuerfelWuerfe() startzeile = 2 For w1 = 1 To 6 For w2 = 1 To 6 For w3 = 1 To 6 For w4 = 1 To 6 Range("A" & startzeile) = w1 Range("B" & startzeile) = w2 Range("C" & startzeile) = w3 Range("D" & startzeile) = w4 startzeile = startzeile + 1 Next w4 Next w3 Next w2 Next w1 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Function GibDenWuerfelCode (AnzahlWürfel as long) as string Dim strFor, strRange, StrNext, strCode as string If isempty(n) then Exit Function For n = 1 to AnzahWürfel If n = 1 then strFor = "For w" & cstr(n) & = 1 To 6" strRange = "Thisworkbook.Activesheet.cells(startzeile," & cstr(n) & ") =W" & cstr(n) strNext = "Next" else strFor = strFor & Chr(10) & "For w" & cstr(n) & = 1 To 6" If n = AnzahlWuerfel then strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & cstr(n) & ") =W" _ & cstr(n) & chr(10) & "startzeile = startzeile + 1" else strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & cstr(n) & ") =W" _ & cstr(n) end if strNext = strNext & chr(10) & "Next" end if next GibDenWuerfelCode = " Function WuerfelCode()" & Chr(10) & strFor & chr(10) & strRange & chr(10) & strNext & chr(10) & "End Function " End Function

Sub test() Call GibDenWuerfelCode(4) End Sub Function GibDenWuerfelCode(AnzahlWürfel As Long) As String Dim strFor, strRange, StrNext, strCode As String For n = 1 To AnzahlWürfel If n = 1 Then strFor = "StartZeile = 1" & Chr(10) & "For w" & CStr(n) & " = 1 To 6" strRange = "Thisworkbook.Activesheet.cells(startzeile," & CStr(n) & ") =W" & CStr(n) StrNext = "Next" Else strFor = strFor & Chr(10) & "For w" & CStr(n) & " = 1 To 6" If n = AnzahlWürfel Then strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & CStr( _ n) & ") =W" & CStr(n) & Chr(10) & "startzeile = startzeile + 1" Else strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & CStr( _ n) & ") =W" & CStr(n) End If StrNext = StrNext & Chr(10) & "Next" End If Next n GibDenWuerfelCode = "Function WuerfelCode()" & Chr(10) & strFor & Chr(10) & strRange & Chr(10) & _ StrNext & Chr(10) & "End Function" Sheets("Tabelle3").Range("A1").Value = GibDenWuerfelCode End Function

Function GibDenWuerfelCode(AnzahlWuerfel As Long, Start As Long) As String Dim strFor, strRange, StrNext, strCode As String If IsEmpty(AnzahlWuerfel) Then Exit Function For n = 1 To AnzahlWuerfel If n = 1 Then strFor = "For w" & CStr(n) & "= 1 To 6" strRange = "Thisworkbook.Activesheet.cells(startzeile," & CStr(n) & ") =W" & CStr(n) StrNext = "Next" Else strFor = strFor & Chr(10) & "For w" & CStr(n) & "= 1 To 6" If n = AnzahlWuerfel Then strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & CStr( _ n) & ") =W" _ & CStr(n) & Chr(10) & "startzeile = startzeile + 1" Else strRange = strRange & Chr(10) & "Thisworkbook.Activesheet.cells(startzeile," & CStr( _ n) & ") =W" _ & CStr(n) End If StrNext = StrNext & Chr(10) & "Next" End If Next GibDenWuerfelCode = " Function WuerfelCode()" & Chr(10) & "startzeile=" & CStr(Start) & Chr(10) & strFor & Chr(10) & strRange & Chr(10) & StrNext & Chr(10) & "End Function " End Function

Function WuerfelCode() startzeile = 3 For W1 = 1 To 6 For W2 = 1 To 6 For W3 = 1 To 6 For W4 = 1 To 6 ThisWorkbook.ActiveSheet.Cells(startzeile, 1) = W1 ThisWorkbook.ActiveSheet.Cells(startzeile, 2) = W2 ThisWorkbook.ActiveSheet.Cells(startzeile, 3) = W3 ThisWorkbook.ActiveSheet.Cells(startzeile, 4) = W4 startzeile = startzeile + 1 Next Next Next Next End Function

Sub werfen(wuerfe, wuerfel As Integer) Dim i As Integer For i = 1 To 6 wuerfe(wuerfel) = i If wuerfel > 1 Then Call werfen(wuerfe, wuerfel - 1) Else Debug.Print Join(wuerfe, "-") End If Next i End Sub

Hallo Micha und Klaus.
Weil ich Michas Ansatz so schon finde, hier das Ganze noch mit Ausgabe der Daten.
Braucht auf meinem Rechner ca. eine halbe Sekunde für 6 Würfe. Die Zeit hängt aber stark vom im Join-Befehl verwendeten Trennzeichen ab, z.B. bei "+" braucht es mehr als 10 Mal so lange. Das von Micha ursprünglich verwendete "-" ist auch noch recht schnell, da dauert es ca. 1,5 s.

Sub test()
Dim erGebnis() As String
Dim wuRf()
Dim zeiLe As Long
Const anzahl_Wuerfel = 6
ReDim erGebnis(1 To 6 ^ anzahl_Wuerfel)
ReDim wuRf(1 To anzahl_Wuerfel)
zeiLe = 1
Call werfen(wuRf, erGebnis, zeiLe, anzahl_Wuerfel)
Application.ScreenUpdating = False
ActiveSheet.Cells(1, 1).Resize(UBound(erGebnis)) = Application.Transpose(erGebnis)
Application.ScreenUpdating = True
End Sub
Sub werfen(ByRef wuRf, ByRef erGebnis, ByRef zeiLe As Long, ByRef wuerfelNr As Integer)
Dim i As Integer
For i = 1 To 6
wuRf(wuerfelNr) = i
If wuerfelNr > 1 Then
Call werfen(wuRf, erGebnis, zeiLe, wuerfelNr - 1)
Else
' Geschwindigkeit hängt stark vom Trennzeichen ab!
erGebnis(zeiLe) = Join(wuRf, "")
zeiLe = zeiLe + 1
End If
Next i
End Sub

Oder fast gleich schnell mit einer Zelle je Würfel

Sub test()
Dim erGebnis()
Dim wuRf()
Dim zeiLe As Long
Const anzahl_Wuerfel = 6
ReDim erGebnis(1 To 6 ^ anzahl_Wuerfel, 1 To anzahl_Wuerfel)
ReDim wuRf(1 To anzahl_Wuerfel)
zeiLe = 1
Call werfen(wuRf, erGebnis, zeiLe, anzahl_Wuerfel, anzahl_Wuerfel)
Application.ScreenUpdating = False
ActiveSheet.Cells(1, 1).Resize(UBound(erGebnis), anzahl_Wuerfel) = erGebnis
Application.ScreenUpdating = True
End Sub
Sub werfen(ByRef wuRf, ByRef erGebnis, ByRef zeiLe As Long, _
ByRef wuerfelNr As Long, ByVal anzahl_Wuerfel As Long)
Dim i As Long
Dim k As Long
For i = 1 To 6
wuRf(wuerfelNr) = i
If wuerfelNr > 1 Then
Call werfen(wuRf, erGebnis, zeiLe, wuerfelNr - 1, anzahl_Wuerfel)
Else
' Geschwindigkeit hängt stark vom Trennzeichen ab!
For k = 1 To anzahl_Wuerfel
erGebnis(zeiLe, k) = wuRf(k)
Next
zeiLe = zeiLe + 1
End If
Next i

Man könnte jetzt auch ein paar globale Variablen deklarieren, anstatt alles immer durchzuschleppen. Hat aber bei der Rechenzeit nichts ausgemacht und daher habe ich es jetzt mal so gelassen.
Gruß, Jogy

Sub test() Dim l As Long, n As Integer, objDict As Object Set objDict = CreateObject("scripting.Dictionary") n = Application.InputBox("Wieviele Würfel ?", , , , , , , 1) If n = False Or n > 6 Then Exit Sub Set objDict = CreateObject("scripting.Dictionary") For l = String(n, "1") To String(n, "6") If Not l Like "*[7-9,0]*" Then objDict(l) = 0 Next Range("A1").Resize(objDict.Count) = WorksheetFunction.Transpose(objDict.keys) End Sub

Sub WuerfelmalmitRosenthal() Dim AnzahlWürfel As Integer, Augen As Long, zae1 As Long AnzahlWürfel = Application.InputBox("Würfelanzahl eingeben.", "Nicht Kombination :)", , , , _ , 1) If AnzahlWürfel = False Or AnzahlWürfel > 6 Then Exit Sub For Augen = String(AnzahlWürfel, "1") To String(AnzahlWürfel, "6") If Not Augen Like "*[7-9,0]*" Then zae1 = zae1 + 1 Cells(zae1, 2) = Augen End If Next Augen End Sub

Sub WuerfelmalmitRosenthal() Dim AnzahlWürfel As Integer, Augen As Long, zae1 As Long, Kombi As Long Dim WürfelArray() As Variant 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 zae1 = zae1 + 1 WürfelArray(zae1, 1) = Augen End If Next Augen Range(Cells(1, 1), Cells(Kombi, 1)) = WürfelArray End Sub

HAllo

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit
Option Base 1

Dim L As Long
Dim arr As Variant

'Micha

Sub test()
Dim dblS As Double
Dim wuerfe()
Dim anzal_wuerfel As Integer
anzal_wuerfel = Application.InputBox("Würfelanzahl eingeben.", "Nicht Kombination :)", 6, , , , 1)
If anzal_wuerfel = False Or anzal_wuerfel > 6 Then Exit Sub
dblS = Timer
L = 0
Redim arr(1 To 6 ^ anzal_wuerfel, 1 To 1)
Redim wuerfe(anzal_wuerfel)
werfen wuerfe, anzal_wuerfel
Range("A1").Resize(UBound(arr), 1) = arr
Debug.Print Timer - dblS '0,3515625
End Sub

Sub werfen(wuerfe, wuerfel As Integer)
Dim i As Integer
For i = 1 To 6
    wuerfe(wuerfel) = i
    If wuerfel > 1 Then
        Call werfen(wuerfe, wuerfel - 1)
    Else
        L = L + 1
        arr(L, 1) = Join(wuerfe, "")
    End If
Next i
End Sub

'EvilRik
Sub WuerfelmalmitRosenthal()
Dim AnzahlWürfel As Integer, Augen As Long, zae1 As Long, Kombi As Long
Dim WürfelArray() As Variant
Dim dblS As Double
AnzahlWürfel = Application.InputBox("Würfelanzahl eingeben.", "Nicht Kombination :)", 6, , , , 1)
If AnzahlWürfel = False Or AnzahlWürfel > 6 Then Exit Sub
dblS = Timer
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
        zae1 = zae1 + 1
        WürfelArray(zae1, 1) = Augen
    End If
Next Augen
Range(Cells(1, 1), Cells(Kombi, 1)) = WürfelArray
Debug.Print Timer - dblS ' 0,421875
End Sub

ransi

Beliebteste Forumthreads (12 Monate)

Mögliche Würfel-Würfe auflisten.

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mögliche Würfel-Würfe auflisten.

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread