kennt jemand eine Funktion(Makro), die prüft, ob eine(bis sechsstellige) Zahl eine bestimmte Anzahl von Teilern hat? Beispiel: 414637 hat genau 5 Teiler:1,19,139,157,414637
Danke im Voraus!
Alifa
A | B | C | D | |
1 | 36 | 1 | 36 | 9 |
2 | 2 | 18 | ||
3 | 3 | 12 | ||
4 | 4 | 9 | ||
5 | 6 | 6 |
Formeln der Tabelle | ||||||||
| ||||||||
Enthält Matrixformel: Umrandende { } nicht miteingeben, sondern Formel mit STRG+SHIFT+RETURN abschließen! | ||||||||
Matrix verstehen |
A | B | C | |
1 | 414637 | 1 | 414637 |
2 | 19 | 21823 | |
3 | 139 | 2983 | |
4 | 157 | 2641 |
Formeln der Tabelle | ||||||
| ||||||
Enthält Matrixformel: Umrandende { } nicht miteingeben, sondern Formel mit STRG+SHIFT+RETURN abschließen! | ||||||
Matrix verstehen |
A | B | C | D | E | |
1 | Zahl | vorg. Anz | Test | Anz. Teiler | |
2 | 414637 | 8 | WAHR | 8 | |
3 | 16 | 4 | FALSCH | 5 | |
4 | 4 | 3 | WAHR | 3 | |
5 | 2 | 1 | FALSCH | 2 |
Formeln der Tabelle | ||||||
|
Function AnzTeiler(z, k) As Boolean 'k ist die vorgegebene Anzahl aller Teiler-2
Dim i&, n As Byte
n = 0
For i = 2 To Fix(z / 2)
If z Mod i = 0 Then n = n + 1
Next i
If n = k Then AnzTeiler = True
End Function
Option Explicit
Function AnzTeilerV(z, k) As Boolean ' k = vorgegebene Anzahl aller Teiler-2
Dim i As Long, n As Byte
For i = 2 To Fix(z / 2)
If z Mod i = 0 Then n = n + 1
Next i
If n = k Then AnzTeilerV = True
End Function
Function AnzTeilerOK(zz, kk) As Boolean ' kk = vorgegebene Anzahl aller Teiler-2
Dim ii As Long, nn As Byte
For ii = 2 To Fix(Sqr(zz)) - 1
If zz Mod ii = 0 Then nn = nn + 2
Next ii
nn = nn - (Sqr(zz) = Fix(Sqr(zz)))
AnzTeilerOK = nn = kk
End Function
Function AnzTeiler(zz) As Long
Dim ii As Long, nn As Byte
For ii = 2 To Fix(Sqr(zz)) - 1
If zz Mod ii = 0 Then nn = nn + 2
Next ii
nn = nn - (Sqr(zz) = Fix(Sqr(zz)))
AnzTeiler = nn
End Function
Function AnzTeilerOK2(zz, kk) As Boolean ' kk = vorgegebene Anzahl aller Teiler-2
AnzTeilerOK2 = AnzTeiler(zz) = kk
End Function
Und hier ein paar Excel-Beispiele:A | B | C | D | E | F | G | H | I | |
1 | Zahl | vorg. Anz | Test | Anz. Teiler | VBA | AnzTeilerV | AnzTeilerOK | AnzTeilerOK2 | |
2 | 414637 | 6 | WAHR | 6 | 6 | WAHR | WAHR | WAHR | |
3 | 16 | 4 | FALSCH | 3 | 3 | FALSCH | FALSCH | FALSCH | |
4 | 4 | 1 | WAHR | 1 | 1 | WAHR | WAHR | WAHR | |
5 | 2 | 1 | FALSCH | 0 | 0 | FALSCH | FALSCH | FALSCH |
Formeln der Tabelle | ||||||||||||||
|
Function AnzTeilerOK(zz, kk) As Boolean ' kk = vorgegebene Anzahl aller Teiler-2
Dim ii As Long, nn As Byte
For ii = 2 To Fix(Sqr(zz - 1))
If zz Mod ii = 0 Then nn = nn + 2
Next ii
nn = nn - (Sqr(zz) = Fix(Sqr(zz)))
AnzTeilerOK = nn = kk
End Function
Function AnzTeiler(zz) As Long
Dim ii As Long, nn As Byte
For ii = 2 To Fix(Sqr(zz - 1))
If zz Mod ii = 0 Then nn = nn + 2
Next ii
nn = nn - (Sqr(zz) = Fix(Sqr(zz)))
AnzTeiler = nn
End Function
Function AnzTeilerOK2(zz, kk) As Boolean ' kk = vorgegebene Anzahl aller Teiler-2
AnzTeilerOK2 = AnzTeiler(zz) = kk
End Function
Sub Kreuzz()
Dim a&, z%, t!, arrE() As Long
t = Timer
Cells.ClearContents
ReDim arrE(1 To 199999 - 100000 + 1)
For a = 100000 To 199999
' If AnzTeilerV(a, 5) Then ' ist langsam
If AnzTeilerOK2(a, 5) Then
' If AnzTeilerOK(a, 5) Then
z = z + 1
arrE(z) = a
End If
Next a
ReDim Preserve arrE(1 To z)
Cells(1, 1).Resize(z) = Application.Transpose(arrE)
Columns(1).AutoFit
MsgBox Round(Timer - t, 1)
End Sub
Noch ein Tipp: Das "Columns(1).AutoFit" habe ich hinter die Schleife verschoben, das muss nur einmal laufen.