[求助]一个计算质数的小程序，请高手优化一下。

qlz110

因为在别的程序中需要质数，所以写了一个计算一定范围内质数的小程序，但随着范围的扩大（如5万），速度越来越慢了，请高手优化一下。

 

qee用

纯数学的东西基本上没用过,在你的基础上改的,供参考.
 Sub aTest()
    Dim m&, n&, k&, a&, b&, arr(), t1
    t1 = Timer
    ReDim arr(1 To 65536)
    k = 1
    Range("D2:D" & Range("D65536").End(xlUp).Row + 1).Clear
    For a = 2 To [a2]
        n = a \ 2
        For b = 2 To n
            If a Mod b = 0 Then Exit For
        Next b
        If b > n Then
            arr(k) = a
            k = k + 1
        End If
    Next a
    ReDim Preserve arr(1 To k - 1)
    Range("D2:D" & k) = Application.Transpose(arr)
    Debug.Print Timer - t1
End Sub

qee用

凭感觉2楼的算法不会是最优的,应该还有更快的方法.
时间太晚,有时间查查质数的算法看看.
欢迎有兴趣的朋友参与.

lotustower

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

' ---Test1

Sub aTest()
    Dim m&, n&, k&, a&, b&, arr(), t1
    t1 = timeGetTime
    ReDim arr(1 To 65536)
    k = 1
    Range("D2:D" & Range("D65536").End(xlUp).Row + 1).Clear
    For a = 2 To [A2]
        n = a \ 2
        For b = 2 To n
            If a Mod b = 0 Then Exit For
        Next b
        If b > n Then
            arr(k) = a
            k = k + 1
        End If
    Next a
    ReDim Preserve arr(1 To k - 1)
    Range("D2:D" & k) = Application.Transpose(arr)
    Debug.Print timeGetTime - t1 & "ms"
End Sub

'--- Test 2

Sub Emily_230606()
    Dim m&, n&, k&, a&, b&, arr(), t1
    t1 = timeGetTime
    ReDim arr(1 To 65536)
    k = 2
    arr(1) = 2

    Range("E2:E" & Range("E65536").End(xlUp).Row + 1).Clear
    For a = 3 To [A2]
        If IsPrime(a) Then
            arr(k) = a
            k = k + 1
        End If
    Next a
    ReDim Preserve arr(1 To k - 1)
    Range("E2:E" & k) = Application.Transpose(arr)
    Debug.Print timeGetTime - t1 & "ms"
End Sub

'

Function IsPrime(TestNumber As Long) As Boolean
Dim Count As Long
Dim Half As Long
If (TestNumber Mod 2) = 0 Then
         Exit Function
 End If
 Half = Sqr(TestNumber)
 For Count = 3 To Half Step 2
     If (TestNumber Mod Count) = 0 Then
         Exit Function
     End If
 Next
 IsPrime = True
End Function
'

'

' A1 = 100000

' P3  800MHz

Test1 ---> 42852ms

Test2 ---> 470ms

qlz110

谢谢用兄及lotustower女士的关注及解答

lotustower女士的方法真是让人大开眼界，a2=600000 时不到5秒完成，用我的程序不知道计算到何月何日。其中解法得慢慢领会。

northwolves

Sub getprime()
Dim max As Long, arr, i As Long, k As Long, beprime As Boolean, t As Single
t = Timer
max = CLng(InputBox("please enter an integer", , 500000))
ReDim arr(1 To max)
arr(1) = 2
arr(2) = 3
i = 5
k = 2
While i <= max
beprime = True
j = 2
Do While j <= Sqr(i)
If i Mod arr(j) = 0 Then beprime = False: Exit Do
j = j + 1
Loop
If beprime = True Then
k = k + 1
arr(k) = i
End If
i = i + 2
Wend
ReDim Preserve arr(1 To k)
Range("c2").Resize(k, 1) = WorksheetFunction.Transpose(arr)
MsgBox "在1--" & max & "内找到" & k & "个质数", vbInformation, "用时" & Timer - t & "秒"
End Sub

northwolves

1. 只在奇数内循环

2. 利用已有的质数

3. 循环到该数字的平方根即可.

其实,递归可能更快,例如:

查询1000000内所有质数,先算出1000内的质数,再看1001-1000000内的奇数能否被1000内的质数整除.

再查询1000内质数,先算出33内的质数,再看35-1000内的奇数能否被33内的质数整除.

再查询33内质数,先算出5内的质数,再看7-33内的奇数能否被5内的质数整除.

UNARTHUR

判断质数的唯一方法就是用从2开始的由小到大的所有质数去试除它。

如果有人能找到比这个更高效的方法那他会成为全世界最伟大的数学家！

呵呵！也就是说那是不可能的。

qlz110

哇，真是百花齐放，各有各的高招。

谢谢northwolves兄解释算法原理。

经测试，还是lotustower的最快！

northwolves

 优化一下:

Sub getprime()
Dim arr, t As Single, n As Long
t = Timer
MAX = CLng(InputBox("please enter an integer", , 800000))
primen MAX, arr
n = UBound(arr)
Range("a1").Resize(n, 1) = WorksheetFunction.Transpose(arr)
MsgBox "在1--" & MAX & "内找到" & n & "个质数", vbInformation, "用时" & Timer - t & "秒"
End Sub

Sub primen(ByVal MAX As Long, ByRef p)
Dim i As Long, j As Long, k As Long, temp, s As Long, n As Long, beprime As Boolean
If MAX = 2 Then
ReDim p(1 To 1)
p(1) = 2
ElseIf MAX = 3 Then
ReDim p(1 To 2)
p(1) = 2
p(2) = 3
End If
If MAX > 4 Then
s = Int(Sqr(MAX))
primen s, temp
n = UBound(temp)
p = temp
k = n
For i = s To MAX
beprime = True
If i Mod 6 = 1 Or i Mod 6 = 5 Then
For j = 2 To n
If i Mod temp(j) = 0 Then beprime = False: Exit For
Next
If beprime = True Then
k = k + 1
ReDim Preserve p(1 To k)
p(k) = i
End If
End If
Next
End If
End Sub