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

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

5ifjDPoc.rar (13.54 KB, 下载次数: 29)

2006-6-23 00:08 上传

点击文件名下载附件
[求助]一个计算质数的小程序，请高手优化一下。

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

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

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

1. 只在奇数内循环

2. 利用已有的质数

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

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

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

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

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

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

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

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

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

谢谢northwolves兄解释算法原理。

经测试，还是lotustower的最快！

 优化一下:

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