Hi Erich,
hier mein Makro. Da ich mit dem String nicht zurecht kam, habe ich die dreistelligen
Primzahlen in verschiedene Spalten ausgelagert.
Option Explicit
Sub StringPrim()
Dim a1, a2, a3, a4, a5, a6, a7, a8
Dim z%, t!, p, b, c
Dim b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, _
b13, b14, b15, b16
t = Timer
Cells.ClearContents
p = Array(113, 131, 137, 139, 173, 179, 191, 193, 197, 199, 311, 313, 317, 331, _
337, 373, 379, 397, 719, 733, 739, 773, 797, 911, 919, 937, 971, 977, 991, 997)
For Each a1 In p
For Each a2 In p
b1 = CInt(Right$(a1, 2) & Left$(a2, 1))
b2 = CInt(Right$(a1, 1) & Left$(a2, 2))
If Ve(Array(b2, b1, a2, a1)) Then
For Each a3 In p
b3 = CInt(Right$(a2, 2) & Left$(a3, 1))
b4 = CInt(Right$(a2, 1) & Left$(a3, 2))
If Ve(Array(b4, b3, a3, b2, b1, a2, a1)) And Prüfen(CStr(a1 & a2 & a3)) Then
For Each a4 In p
b5 = CInt(Right$(a3, 2) & Left$(a4, 1))
b6 = CInt(Right$(a3, 1) & Left$(a4, 2))
If Ve(Array(b6, b5, a4, b4, b3, a3, b2, b1, a2, a1)) And Prüfen(CStr(a1 & a2 & a3 & a4)) Then
For Each a5 In p
b7 = CInt(Right$(a4, 2) & Left$(a5, 1))
b8 = CInt(Right$(a4, 1) & Left$(a5, 2))
If Ve(Array(b8, b7, a5, b6, b5, a4, b4, b3, a3, b2, b1, a2, a1)) _
And Prüfen(CStr(a1 & a2 & a3 & a4 & a5)) Then
For Each a6 In p
b9 = CInt(Right$(a5, 2) & Left$(a6, 1))
b10 = CInt(Right$(a5, 1) & Left$(a6, 2))
If Ve(Array(b10, b9, a6, b8, b7, a5, b6, b5, a4, b4, b3, a3, b2, b1, a2, a1)) _
And Prüfen(CStr(a1 & a2 & a3 & a4 & a5 & a6)) Then
For Each a7 In p
b11 = CInt(Right$(a6, 2) & Left$(a7, 1))
b12 = CInt(Right$(a6, 1) & Left$(a7, 2))
If Ve(Array(b12, b11, a7, b10, b9, a6, b8, b7, a5, b6, b5, a4, b4, b3, a3, b2, b1, a2, a1)) _
And Prüfen(CStr(a1 & a2 & a3 & a4 & a5 & a6 & a7)) Then
For Each a8 In p
b13 = CInt(Right$(a7, 2) & Left$(a8, 1))
b14 = CInt(Right$(a7, 1) & Left$(a8, 2))
If Ve(Array(b14, b13, a8, b12, b11, a7, b10, b9, a6, b8, b7, _
a5, b6, b5, a4, b4, b3, a3, b2, b1, a2, a1)) _
And Prüfen(CStr(a1 & a2 & a3 & a4 & a5 & a6 & a7 & a8)) Then
b = CStr(a1 & a2 & a3 & a4 & a5 & a6 & a7 & a8)
z = z + 1
If z = 1000 Then Exit Sub
Cells(z + 2, 1).Resize(, 8) = Array(a1, a2, a3, a4, a5, a6, a7, a8)
Cells(1, 1).Resize(, 8) = Array("a1", "a2", "a3", "a4", "a5", "a6", "a7", "a8")
Columns.AutoFit
End If: Next: End If: Next: End If: Next: End If: Next: End If: Next:
End If: Next: End If: Next: Next
Columns.AutoFit
MsgBox Round(Timer - t, 1)
End Sub
Function Prüfen(ByVal s As String) As Boolean
Dim i&
For i = 1 To Len(s) - 2
If Not Prim(Mid$(s, i, 3)) Then Exit Function
Next:
Prüfen = True
End Function
Function Prim(ByVal z&) As Boolean
Dim X%
For X = 3 To Int(Sqr(z))
If z Mod X = 0 Then Prim = False: Exit Function
Next X
Prim = True
End Function
Private Function Ve(arrWerte) As Boolean 'prüft, ob alle Variabeln
Dim ii As Long, oCollection As New Collection 'unterschiedlich sind
On Error GoTo Fehler ' von Franz
Ve = True ' If Ve(array(a1,a2,...)) Then
For ii = LBound(arrWerte) To UBound(arrWerte)
oCollection.Add arrWerte(ii), CStr(arrWerte(ii))
Next
Fehler:
If Err.Number 0 Then
Ve = False
End If
Set oCollection = Nothing
End Function
Gruß, Erhard