Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 53316 Skopiuj do schowka Liczby pierwsze
Autor Wiadomość
darkous 
Exceloholic


Wersja: Mac Office 2016
Pomógł: 25 razy
Posty: 164
Wysłany: 28-07-2016, 22:40   Liczby pierwsze

Witam.
Ostatnio trochę przyszło mi zajmować sie (głównie z zainteresowania) liczbami pierwszymi i ich największymi postaciami, możliwymi do obliczenia przez excel..
Napisałem pewien kodzik, który niestety powyżej i = 100 000 trwa już wieki (do 10tyś jeszcze ujdzie w tłoku).
I moje pytanie - czy da się jeszcze efektywniej je przeliczać?

Cytat:

Option Explicit
Sub pierwsze()

Dim i, k, m, n, t As Double
Dim moje() As Long

t = 1
For i = 2 To 100000
m = 0
For k = i To 2 Step -1
If i Mod k = 0 Then
m = m + 1
End If
Next k

If m = 1 Then
ReDim Preserve moje(t)
moje(t) = i
t = t + 1

End If
Next i

n = 1
For k = 1 To UBound(moje)
Cells(n, 1) = moje(k)
n = n + 1
Next k

End Sub

ID posta: 299388 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 28-07-2016, 23:33   

Kod:
For k = i To 2 Step -1
  If i Mod k = 0 Then
   m = m + 1
  End If
Next k


Dzielenie powinieneś wykonywać do 2 do i/2.
Wszystko co jest powyżej połowy dzielnej nie może być jej dzielnikiem w przypadku poszukiwań liczb pierwszych.

Dodatkowo nie ma sensu sprawdzać wszystkich dzielników, jeżeli podczas sprawdzania choć jeden z nich dzieli dzielną bez reszty.

Kod:
Sub liczPierwsze()
  Const maxNum As Long = 10000
  Dim i As Long
  Dim j As Long
  Dim t() As Long, k As Long
 
  For i = 4 To maxNum
    For j = 2 To CLng(i / 2) + 1
      If i Mod j = 0 Then
        GoTo nextNum
      End If
    Next
   
    ReDim Preserve t(k)
    t(k) = i
    k = k + 1
nextNum:
  Next
 
End Sub
ID posta: 299390 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 29-07-2016, 00:38   

No to kolega kulasart, pozamiatał :-) .

Nie wgryzałem się w algorytm Liczb pierwszych, więc dokonałem tylko kosmetyki Twojego kodu i udało się go lekko przyspieszyć.
W załączniku wszystkie 3 makra z podanym czasem wykonywania.

Dokonałem też w nim lekkiej modyfikacji kodu Łukasza- chyba nie będzie miał mi tego za złe.
Zmiana polegająca na modyfikacji konstrukcji:
Kod:
If ..coś then
..coś..
end If
na
Kod:
If ..coś.. then ..coś..
taka konstrukcja jest szybsza.

Pozbyłem się też
Kod:
ReDim Preserve t(k)
na z góry zadeklarowaną tablicę
Kod:
Dim tbl(1 To maxNum / 2, 1 To 1) As Long
tablica jest dużo większa, ale myślę że nie ma to większego znaczenia - no chyba że otrzymamy błąd o braku pamięci.

liczby pierwsze.xlsm
Pobierz Plik ściągnięto 180 raz(y) 22.25 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 299391 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4482
Wysłany: 29-07-2016, 01:37   

Tylko 100 tysięcy?
Proszę testować dla zakresu 1-10000000 (10 milionów!!!). Nie zdążyłem nawet przełączyć kanał w TV ;-)

Po usunięciu komentarzy kod jest całkiem krótki

Zastosowałem algorytm zwany sito Eratostenesa

Kod:

Sub pierwsze()
'    algorytm: kiedy znajdziemy liczbę pierwszą x to zaznaczymy wszystkie jej wielokrotności w tablicy findArr liczbą 1,
'    w ten sposób: findArr(x) = 1, findArr(2x) = 1, ... Po tym pierwsza liczba x spełniająca findArr(x) <> 1
'    jest liczbą pierwszą.
'    Najpierw dodajemy do znalezionych liczbę pierwszą 2.
'    Rozpoczywamy szukanie od liczby start = 3, i szukamy tylko wśród liczb nieparzystych
'    jeśli trafimy ma findArr(start) <> 1 to znaczy, że liczba start jest liczbą pierwszą i wtedy robimy następujące kroki:
'    1. dodajemy liczbę pierwszą start do znalezionych
'    2. od indeksu tempindex = start zaznaczymy wszystkie wielokrotności liczby pierwszej start w tablicy findArr liczbą 1
'    3. rozpoczynamy nowe szukanie od start + 2 (start zawsze jest liczbę nieparzystą)
Dim t As Double
Dim moje() As Long, findArr() As Byte, result() As Long, size As Long, start As Long, tempindex As Long
    t = Timer
'    szukamy liczb pierwszych wśród size liczb naturalnych
    size = 10000000
'    tablica size liczb
    ReDim findArr(1 To size)
'    na  początek tablica znalezionych zawiera 1 liczbę pierwszą 2
    ReDim moje(1 To 1)
    moje(1) = 2
'    rozpoczywamy przeglądanie tablicy findArr od indeksu 3
    start = 3
    Do While start <= size
'        przeglądamy tablicę findArr aż indeks start > 1 lub aż trafimy na element niezaznaczony liczbą 1
        Do While start <= size
            If findArr(start) <> 1 Then Exit Do
            start = start + 2
        Loop
'        w tym miejscu jeśli start <= size to znaczy, że start jest liczbą pierwszą.
        If start <= size Then
'            powiększamy tablicę znalezionych i zapisujemy znalezioną liczbę pierwszą start
            ReDim Preserve moje(1 To UBound(moje) + 1)
            moje(UBound(moje)) = start
            tempindex = start
'            zaznaczymy wszystkie wielokrotności liczby pierwszej start w tablicy findArr
            Do While tempindex <= size
                findArr(tempindex) = 1
                tempindex = tempindex + start
            Loop
'            rozpoczynamy nowe przeglądanie tablicy findArr od indeksu o 2 większego
            start = start + 2
        End If
    Loop
    Application.ScreenUpdating = False
    ReDim result(1 To UBound(moje), 1 To 1)
    For start = 1 To UBound(result)
        result(start, 1) = moje(start)
    Next start
'    jednym  rzutem wrzucamy tablicę do arkusza
    Range("A1").Resize(UBound(result)).Value = result
    Application.ScreenUpdating = True
   
    MsgBox "zrobiono w " & Timer - t & "sekund"
End Sub
ID posta: 299394 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 29-07-2016, 08:16   

:clap :clap :clap apollo,

@apollo, tego If-a możemy się pozbyć .
Kod:
If start <= size Then
;-)

edit:

Już wiem że nie możemy ;-)
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
Ostatnio zmieniony przez Marecki 29-07-2016, 15:19, w całości zmieniany 3 razy  
ID posta: 299408 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 29-07-2016, 10:56   

Marecki, możesz podać jakiś przykład (dla mojego algorytmu)?

apollo, GOOD JOB - to jeden z najciekawszych algorytmów do znajdowania liczb pierwszych.
ID posta: 299433 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 29-07-2016, 11:25   

Łukasz bardzo Cię przepraszam, oczywiście jest wszystko dobrze.
Nie wiem jak ja na to patrzyłem, lub coś zmieniłem w kodzie że wyniki miałem inne :oops: .
Jeszcze raz sorki.
Już poprawiam wcześniejszego posta by nie robić zamieszania.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 299437 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 29-07-2016, 11:58   

Marecki, nie ma problemu. Lekko mnie tym zaskoczyłeś i zacząłem wątpić w to co napisałem (tym bardziej że pisałem bez testów) ale byłem przekonany że musi działać.
ID posta: 299439 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4482
Wysłany: 29-07-2016, 14:46   

Marecki napisał/a:
:clap :clap :clap apollo,

@apollo, tego If-a możemy się pozbyć .
Kod:
If start <= size Then
;-)



kolego Marecki, za wcześnie się cieszysz ;-)

Każdy programuje inaczej, ma swoje nawyki, ocenia inaczej. Np. nigdy nie widziałeś i nie będziesz widział u mnie: ReDim findArr(1 To size) As Byte, kilka instrukcji w jednym wierszu, deklarowanie niepotrzebnie dużej tablicy (to ostatnie się zdarzał ale bardzo rzadko). Zawsze deklaruję zmienne na początku, Nie dzielę instrukcji w jednym wierszu dwukropkiem, nie rezerwuję tablicy na 10 milionów elementów żeby mieć w pamięci tablicę 40 MB, skoro potrzebuję o wiele mniej. Poza tym zawsze staram się pisać kod tak, zeby potem ktoś mniej się zna na VBA mógł sam poprawić. A i ustawienie na sztywno size = 10000000 bo to tylko przykład. I tak trzeba zmienić kod żeby przekazać size jako parametr. I kod musi działać i dla 10000000 i dla 100000, i dla 25.

Możesz poprawić dla siebie ale zostawiam swój kod dla siebie. Tym bardziej, że źle poprawiłeś.

Mówisz, że
Kod:

If start <= size Then

jest niepotrzebne?
Zobacz swój poprawiony kod
Kod:

Do While start <= size
            If findArr(start) <> 1 Then Exit Do
            start = start + 2
        Loop

        i = i + 1
        moje(i, 1) = start

Czyli wg Ciebie po Do ... Loop to na pewno start jest liczbą pierwszą i trzeba ładować do tablicy znalezionych moje? Tak jest tylko kiedy wyjście nastąpiło wskutek Exit Do. Jeśli nie ma więcej liczb do sprawdzenia, czyli wyjście wskutek niespełnienia warunku w linii
Kod:

Do While start <= size

To start niekoniecznie jest liczbą pierwszą. Nawet jeśli jest, bo na szczęście dla Ciebie są liczby pierwsze bliźniacze 2k+1 i 2k+3, to i tak "niepotrzebna" bo jest poza zakresem ustalonym przeze mnie - size (np. dla size = 10, masz dodatkowo nieproszoną liczbę pierwszą 11 poza ustalonym zakresem).
A są przypadki, kiedy na pewno start nie jest liczbą pierwszą, a takie przypadki są dominujące bo wśród ogromnych liczb to liczby pierwsze są coraz rzadsze (można znaleźć dowolnie długi zakres kolejnych liczb, które wszystkie są złożone). Jeśli to co piszę nie jest jeszcze zrozumiałe dla Ciebie to ustaw size = 25 i zobacz wyniki. W moje i na arkuszu są 2, 3, 5, 7, 11, 13, 17, 19, 23, 27.
A każdy wie, ze 27 nie jest liczbą pierwszą.

Dla size = 33 wyniki: 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 35

a 35 nie jest liczbą pierwszą.
--------------
No i taki kod opatrzyłeś komentarzem
Cytat:

'kod kolegi apollo

???

No kolego Marecki, to już nie mój kod. Chcesz, żebym dostał zgniłe pomidory i zepsute cuchnące jajka? ;-)
ID posta: 299467 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 29-07-2016, 15:25   

apollo, dzięki za wytłumaczenie, już wiem jaki popełniłem błąd.
Kod oczywiście usunąłem.
Sorki za kłopot, ale dzięki temu jestem mądrzejszy ;-)
3maj się. :beer
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 299476 Skopiuj do schowka
 
 
darkous 
Exceloholic


Wersja: Mac Office 2016
Pomógł: 25 razy
Posty: 164
Wysłany: 29-07-2016, 23:13   

Apollo, uprzedziłeś mnie z tym sitem. Planowałem to napisać choć nie ukryje, miałem małe problemy implementacji. Miazga!
Dziękuję swoją drogą za odzew, przejrzenie Waszych pomysłów rzuciło mi kolejne drogi pisania :)
ID posta: 299497 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2385 razy
Posty: 7806
Wysłany: 29-07-2016, 23:56   

Kod:
Sub LP()
    Dim Tbl() As Byte
    Dim t#, Max_do&, i&, w&, j&, k&

    t = Timer: Max_do = 10000000

    ReDim Tbl(Max_do)
    For i = 2 To Max_do
        Tbl(i) = 1
    Next i

    For i = 2 To VBA.Sqr(Max_do)
        If Tbl(i) > 0 Then
            w = i * i
            While w <= Max_do
                Tbl(w) = 0: w = i + w
            Wend
        End If
    Next

    ReDim tbl_out(1 To Max_do, 1 To 1) As Long

    For i = 2 To Max_do
        If Tbl(i) > 0 Then k = k + 1: tbl_out(k, 1) = i
    Next i

    Range("C1").Resize(k).Value = tbl_out
    MsgBox Timer - t & " sek"

End Sub

Też oparte o algorytm Eratostenesa.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 299498 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1295 razy
Posty: 4482
Wysłany: 30-07-2016, 21:32   

Marecki napisał/a:

Też oparte o algorytm Eratostenesa.

Marecki, dobra robota, brawo
------
Uznałem, że tablice result i moje (moje to tak naprawdę tablica pytającego a ja nie myślałem, żeby zmienić) w moim kodzie nie są potrzebne. Podaję poprawiony kod używający tylko 1 tablicy findArr
Kod:

Sub pierwsze()
Dim t As Double
Dim findArr() As Long, size As Long, start As Long, index As Long
    t = Timer
    Range("A:A").ClearContents
    size = 10000000
    ReDim findArr(1 To size, 1 To 1)
    findArr(1, 1) = 2
    start = 3
    Do While start <= size
        Do While start <= size
            If findArr(start, 1) <> 1 Then Exit Do
            start = start + 2
        Loop
        If start <= size Then
            index = 2 * start
            Do While index <= size
                findArr(index, 1) = 1
                index = index + start
            Loop
            start = start + 2
        End If
    Loop
    index = 1
    For start = 3 To size Step 2
        If findArr(start, 1) <> 1 Then
            index = index + 1
            findArr(index, 1) = start
        End If
    Next start
    Application.ScreenUpdating = False
    Range("A1").Resize(index).Value = findArr
    Application.ScreenUpdating = True

    MsgBox "zrobiono w " & Timer - t & "sekund"
End Sub
ID posta: 299538 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2940 razy
Posty: 9714
Wysłany: 03-08-2016, 10:42   

To może o rząd wielkości więcej liczb? :-)
Kod:
Sub LP_2()
          Dim Tbl()       As Byte
          Dim t#, Max_do&, i&, w&, j&, k&
          Dim rwCnt       As Long
          Dim vPos        As Variant

10        On Error GoTo HandleError

20        Range("C1").CurrentRegion.EntireColumn.Delete

30        Application.Cursor = xlWait

40        t = Timer: Max_do = 130000000

50        ReDim Tbl(Max_do)
60        For i = 2 To Max_do
70            Tbl(i) = 1
80        Next i

90        For i = 2 To VBA.Sqr(Max_do)
100           If Tbl(i) > 0 Then
110               w = i * i
120               While w <= Max_do
130                   Tbl(w) = 0: w = i + w
140               Wend
150           End If
160       Next

170       ReDim tbl_out(1 To Max_do, 1 To 1) As Long

180       For i = 2 To Max_do
190           If Tbl(i) > 0 Then k = k + 1: tbl_out(k, 1) = i
200       Next i

210       rwCnt = Rows.Count

220       ReDim tbl_out1(1 To rwCnt, 1 To k \ rwCnt + 1) As Long

230       j = 1: w = 1


240       For i = 1 To k
250           tbl_out1(j, w) = tbl_out(i, 1)

260           j = j + 1

270           If i = rwCnt * w Then
280               j = 1: w = w + 1
290           End If
300       Next i


310       With Range("C1").Resize(UBound(tbl_out1), UBound(tbl_out1, 2))
320           .Value = tbl_out1
330           .EntireColumn.AutoFit
340           vPos = Application.Match(0, .Columns(UBound(tbl_out1, 2)), 0)
350           If Not IsError(vPos) Then
360               Range(Cells(vPos, UBound(tbl_out1, 2) + .Column - 1), Cells(rwCnt, UBound(tbl_out1, 2) + .Column - 1)).ClearContents
370           End If
380       End With


390       MsgBox Timer - t & " sek"

HandleExit:
400       Application.Cursor = xlDefault
410       Exit Sub

HandleError:
420       MsgBox Err.Number & vbLf & Err.Description & vbLf & "In line " & Erl(), vbCritical
430       Resume HandleExit

End Sub


Artik
ID posta: 299673 Skopiuj do schowka
 
 
kulasart
[Usunięty]

Wysłany: 03-08-2016, 11:25   

Artik, czyżbym widział zmodyfikowaną wersje Sita Erastotenesa, którą zaproponował Euler?
ID posta: 299680 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe