Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
25.04.2024 21:21:16
Zellkommentar in UserForm anzeigen und bearbeiten
25.04.2024 21:13:13
Kalenderwochen addieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
976to980
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Primzahlen

Primzahlen
21.05.2008 03:53:00
Mustafa
Hallo alle miteinander,
folgender Code ermittelt aus dem Bereich A1:J100, in dem die Zahlen von 1 bis 1000 stehen, die Primzahlen heraus und markiert die Zellen rot.
Falls jemand die Tabelle kurz nachbaun möchte, in A1 darf nicht 1 stehen weil dann alle Zellen rot markiert werden.
Dort dann einfach Max(J:J) reinschreiben, weil dort ein Wert größer 0 stehen.
In diesem Falle würde dort 1000 stehen.
Option Explicit

Sub primzahl()
Dim Zelle1 As Range, Zelle2 As Range
Dim Bereich As Range
Dim Ergebnis As Long
Cells(1, 11) = Time
Application.ScreenUpdating = False
Set Bereich = Range("A1:J100")
For Each Zelle1 In Bereich
For Each Zelle2 In Bereich
If Intersect(Zelle1, Zelle2) Is Nothing Then
Ergebnis = Zelle2 Mod Zelle1
If Ergebnis = 0 Then
Zelle2.Interior.ColorIndex = 3
End If
End If
Next
Next
Application.ScreenUpdating = True
Cells(1, 12) = Time
End Sub


Nur dauert der Code bei meinem Rechner 1:02 minuten.
Kann man den Code etwas "Beschleunigen"
Gruß Aus der Domstadt Köln.
Vielen Dank jetzt schon an alle Helfer.

22
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
bedingtes Format ist auch möglich ;o)
21.05.2008 05:59:04
Matthias
Hallo Mustafa
anbei eine Tabelle, die ich so aufgebaut habe, wie in Deinem Beitrag geschildert
https://www.herber.de/bbs/user/52501.xls
Gruß Matthias

AW: bedingtes Format ist auch möglich ;o)
21.05.2008 06:12:00
Mustafa
Hallo Matthias,
vielen Dank für die schnelle Antwort, und das noch zu so früher Stunde.
Werde den Code heute Abend mal ausseinander nehmen um ihn zu verstehen.
Nochmal herzlichen Dank, der code braucht bei meinem Rechner grad mal ca 3 sekunden.
Gruß aus Köln.

AW: bedingtes Format ist auch möglich ;o)
21.05.2008 06:20:00
Mustafa
Hallo nochmal Matthias,
Habe doch noch mal reingeschaut in den Code.
Mir ist nur aufgefallen das die 2 nicht als Primzahl angezeigt wird, ansonsten ist es perfekt und einfach gemacht.
Nochmals herzlichen Dank an dich.
PS: Die farbliche Erkennung ist nicht das wichtige gewesen, nötiger war es die Primzahlen aufzulisten, aber das hast du ja direkt mitgemacht.

Anzeige
AW: bedingtes Format ist auch möglich ;o)
21.05.2008 08:07:09
Matthias
hallo Mustafa
Ändere in der For Schleife den Wert von 3 auf 2

For i = 2 To 1000


Gruß Matthias

AW: bedingtes Format ist auch möglich ;o)
21.05.2008 09:33:00
Uwe
Hi,
ich war mal so frech und habe Mathias' Code etwas modifiziert. Damit ist er noch um einiges schneller, weil er aus der inneren Schleife "springt", sobald MOD das erstemal 0 ist. Damit bekomme ich die Primzahlen bis 100.000 auf meinem Rechner in 25 Sekunden:

Sub primZ()
Dim i As Long, Anzahl As Boolean, z As Long
Application.ScreenUpdating = False
For i = 2 To 100000
Anzahl = False
For z = 2 To i - 1
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then [L65536].End(xlUp).Offset(1, 0) = i
Next i
Application.ScreenUpdating = True
End Sub




Sub rst()
Range("L:L").ClearContents
End Sub


Gruß
Uwe
(:o)

Anzeige
AW: bedingtes Format ist auch möglich ;o)
21.05.2008 09:42:38
udoof
Hi Uwe,
zur weiteren Optimierung reicht es, wenn die innere Schleife bis Wurzel (i) rechnet, nicht bis (i-1).
Grüßle,
Udo

AW: Super Idee
21.05.2008 09:50:00
Uwe
Hi Udo,
Super Idee. DANKE!!!
Damit bin ich bei sieben Sekunden für die 100.000:
Option Explicit

Sub primZ()
Dim i As Long, Anzahl As Boolean, z As Long
Application.ScreenUpdating = False
For i = 2 To 100000
Anzahl = False
For z = 2 To Sqr(i)
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then [L65536].End(xlUp).Offset(1, 0) = i
Next i
Application.ScreenUpdating = True
End Sub




Sub rst()
Range("L:L").ClearContents
End Sub


Gruß
Uwe
(:o)

Anzeige
Primzahlen-Auflistung
21.05.2008 10:07:00
Rudi
Hallo,
erst alle Zahlen in ein Array packen und dann in die Tabelle schreiben!
Unter 0,4 sekunden:

Sub primZ()
Dim t
t = Timer
Dim i As Long, Anzahl As Boolean, z As Long
Dim vntPrim(), n As Long
ReDim vntPrim(1 To 1, 1 To 100000)
Application.ScreenUpdating = False
For i = 2 To 100000
Anzahl = False
For z = 2 To Sqr(i)
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then
n = n + 1
vntPrim(1, n) = i
End If
Next i
ReDim Preserve vntPrim(1 To 1, 1 To n)
Sheets(1).Range("l1").Resize(n) = WorksheetFunction.Transpose(vntPrim)
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub


Gruß
Rudi

Anzeige
Laufzeitfehler!
21.05.2008 10:22:00
Matthias
Hallo Rudi
Code ist in Modul1
Bei mir kommt Laufzeitfehler 13 in der Zeile
Sheets(1).Range("l1").Resize(n) = WorksheetFunction.Transpose(vntPrim)
Hast Du ne Idee, warum?
Gruß Matthias

AW: Laufzeitfehler!
21.05.2008 10:36:00
Rudi
Hallo,
keine Ahnung. Bei mir (XLXP) läuft's.
Vielleicht liegt's am Resize.
Versuchs mal so:

ReDim Preserve vntPrim(1 To 1, 1 To n)
With Sheets(1)
.Range(.Cells(1, 12), .Cells(n, 12)) = WorksheetFunction.Transpose(vntPrim)
End With


Gruß
Rudi

geht leider auch nicht (Laufz.Fehler 13)
21.05.2008 10:46:03
Matthias
Hallo Rudi
Gleicher Fehler, noch ne andere Idee. Ich hab XL2000
Gruß Matthias

Anzeige
Läuft auf XL2000 bis 53608
21.05.2008 10:50:00
Renee
Hi Matthias,
Bin auch noch am Knobeln. Der Code bringt ab dem Grenzwert 54608+ einen Laufzeitfehler.
53608 ergibt eine Arraygrösse von 5461
Ich hab aber noch keinen Anhaltspunkt wieso.
GreetZ Renée

AW: Läuft auf XL2000 bis 53608
21.05.2008 11:08:00
Rudi
Hallo,
liegt es evtl an der Transponiererei?

Sub primZ()
Dim t
t = Timer
Dim i As Long, Anzahl As Boolean, z As Long
Dim vntPrim(), n As Long, vntTmp()
ReDim vntPrim(1 To 1, 1 To 100000)
Application.ScreenUpdating = False
For i = 2 To 53610
Anzahl = False
For z = 2 To Sqr(i)
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then
n = n + 1
vntPrim(1, n) = i
End If
Next i
ReDim vntTmp(1 To n, 1 To 1)
For i = 1 To n
vntTmp(i, 1) = vntPrim(1, i)
Next
With Sheets(1)
.Range(.Cells(1, 12), .Cells(n, 12)) = vntTmp
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub


Gruß
Rudi

Anzeige
AW: Läuft auf XL2000 bis 53608
21.05.2008 11:38:00
Renee
Hi Rudi,
Ich bastle da rum, und du präsentierst die Lösung schon lange vorher.
Déjà vu: Da sieht man mal wieder wie die Posts gelesen werden ;-)
Dein neuer Code läuft ohne Probleme bis 1'000'000 auch unter XL2000.
GreetZ Renée

OK, das waren 178'355 zuviel ;-) (owT)
21.05.2008 12:10:00
Renee

Danke, Renée oT
21.05.2008 11:07:00
Matthias

XL2000 bis 100'000
21.05.2008 11:31:00
Renee
Hi all,
Mit einer selbstdefinierten Transpose-Funktion (siehe XL Limits) läufts auch für XL2000:

Sub primZ()
Dim t
t = Timer
Dim i As Long, Anzahl As Boolean, z As Long
Dim vntPrim(), n As Long
ReDim vntPrim(1 To 1, 1 To 100000)
Application.ScreenUpdating = False
For i = 2 To 100000
Anzahl = False
For z = 2 To Sqr(i)
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then
n = n + 1
vntPrim(1, n) = i
End If
Next i
ReDim Preserve vntPrim(1 To 1, 1 To n)
Sheets(1).Range("A1").Resize(n) = TransposeDim(vntPrim)
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
Function TransposeDim(v As Variant) As Variant
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(1 To Xupper, 1 To Yupper)
For X = 1 To Xupper
For Y = 1 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function


... und immer noch viel schneller als die anderen Vorschläge ;-)
GreetZ Renée

Anzeige
AW: Rudi ist Erster Sieger! (;-)
21.05.2008 10:23:00
Uwe
Hi Rudi,
ok gegen Deinen Ferari-Code kommt mein Fahrrad-Code nicht an, aber irgendwie habe ich immer noch zuviel "Respekt" vor Arrays in VBA.
Gruß
Uwe
(:o)

AW: Rudi ist Erster Sieger! (;-)
21.05.2008 21:16:00
Gerd
Hallo zusammen,
gerade Zahlen kann man noch überspringen.

Sub primZ()
Dim t
t = Timer
Dim i As Long, Anzahl As Boolean, z As Long
Dim vntPrim(), n As Long, vntTmp()
ReDim vntPrim(1 To 1, 1 To 100000)
Application.ScreenUpdating = False
vntPrim(1, 1) = 2
n = 1
For i = 3 To 53609 Step 2
Anzahl = False
For z = 2 To Sqr(i)
If i Mod z = 0 Then
Anzahl = True
Exit For
End If
Next z
If Anzahl = False Then
n = n + 1
vntPrim(1, n) = i
End If
Next i
ReDim vntTmp(1 To n, 1 To 1)
For i = 1 To n
vntTmp(i, 1) = vntPrim(1, i)
Next
With Sheets(1)
.Range(.Cells(1, 12), .Cells(n, 12)) = vntTmp
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub


Grüße Gerd

Anzeige
AW: Rudi ist Erster Sieger! (;-)
22.05.2008 00:00:31
Mustafa
Hallo Alle zusammen,
erst einmal ein großes WOW !!!
Ich hatte zwar mit schnelleren Codes gerechnet, aber das dann so viel Resonanz kommt und hier scheinbar alle ein kleines Wettrennen veranstalten, daran hätt ich im Traum nicht gedacht.
Noch einmal ein Herzliches Dankeschön an alle die beherzt mitgeholfen haben.
Werde mir alle Codes einmal durchschauen.
Ich bin sicher das ich heute wieder so einiges lernen kann.
Grüße aus der Domstadt Köln und einen Wunderschönen Feiertag an alle.

AW: Rudi ist Erster Sieger! (;-)
22.05.2008 01:05:00
Rudi
Hallo,
klar!
Und eigentlich muss man auch nur die Division durch die schon ermittelten Primzahlen testen (Sieb des Erastotenes). Das bringt aber nicht mehr.
Gruß
Rudi
Eine Kuh mach muh, viele Kühe machen Mühe.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige