222 Möglichkeiten ?
26.09.2010 13:20:52
ransi
Hallo Alifa
Ausgehend von Erqus Forderung:
'suche eine 10-stellige Primzahl.Jede Ziffer
'ist so oft vorhanden, wie ihr Wert.Beispiel:3666366613
Erstmal etwas Vorarbeit.
Das sind die Zahlen aus deren Permutationen so etwas gemacht werden kann:
9999999991
8888888822
7777777333
7777777221
6666664444
6666663331
5555544441
5555533322
4444333221
Wobei 6666664444 und 8888888822 rausfallen weil die immer durch 2 teilbar sind.
Jetzt mal diesen Code:
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Dim myDic As Object
Public Sub test()
Dim arr As Variant
Dim i As Integer
Dim L As Long
Dim Ding
Dim objItems
Redim out(L)
arr = Array(9999999991#, 7777777333#, 7777777221#, 6666663331#, 5555544441#, 5555533322#, 4444333221#)
Set myDic = CreateObject("Scripting.dictionary")
For i = LBound(arr) To UBound(arr)
myDic.removeall 'Dictionary leeren
Textdreher "", arr(i)
objItems = myDic.keys
For Each Ding In objItems
If primzahltest(Ding) Then
Redim Preserve out(L) 'Ausgabearray neu dimensionieren
out(L) = Ding
L = L + 1
End If
Next
Next
'Ausgeben
Range("A1").Resize(UBound(out) + 1) = WorksheetFunction.Transpose(out)
End Sub
Public Sub Textdreher(x As String, ByVal y As String)
'http://www.schmittis-page.de/excel/vba/t26.htm
Dim i As Integer, j As Integer
j = Len(y)
If j < 2 Then
' Zeile = Zeile + 1
myDic(x & y) = 0 'Permutationen ohne Duplicate ins Dictionary
Else
For i = 1 To j
Call Textdreher(x + Mid(y, i, 1), _
Left(y, i - 1) + Right(y, j - i))
Next
End If
End Sub
Public Function primzahltest(lngZahl) As Boolean
'bst
Dim i
If lngZahl > 4 Then
If lngZahl / 2 = Int(lngZahl / 2) Then Exit Function ' Zahl ist durch 2 teilbar
If lngZahl / 3 = Int(lngZahl / 3) Then Exit Function ' Zahl ist durch 3 teilbar
' von den Zahlen 6*n-1 bis 6*n+5 nur noch 6*n-1 und 6*n+1 testen da:
' 6*n, 6*n+2, 6*n+4 durch 2, 6*n+3 durch 3 teilbar ist
' und dieses bereits zuvor getestet wurde
For i = 6 To Int(Sqr(lngZahl)) + 1 Step 6
If lngZahl / (i - 1) = Int(lngZahl / (i - 1)) Then Exit Function
If lngZahl / (i + 1) = Int(lngZahl / (i + 1)) Then Exit Function
Next
primzahltest = True
Else ' es verbleiben die Zahlen <= 4, von denen sind nur 2 und 3 Primzahlen
primzahltest = lngZahl = 2 Or lngZahl = 3
End If
End Function
Der Code braucht bei mir ca. 1 Minute.
ransi