ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 6090|回复: 22

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2006-6-23 00:08 | 显示全部楼层 |阅读模式

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

 

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

TA的精华主题

TA的得分主题

发表于 2006-6-23 00:29 | 显示全部楼层
纯数学的东西基本上没用过,在你的基础上改的,供参考.
 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

TA的精华主题

TA的得分主题

发表于 2006-6-23 00:39 | 显示全部楼层
凭感觉2楼的算法不会是最优的,应该还有更快的方法.
时间太晚,有时间查查质数的算法看看.
欢迎有兴趣的朋友参与.

TA的精华主题

TA的得分主题

发表于 2006-6-23 02:35 | 显示全部楼层

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-6-23 08:29 | 显示全部楼层

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

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

TA的精华主题

TA的得分主题

发表于 2006-6-23 08:42 | 显示全部楼层
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

TA的精华主题

TA的得分主题

发表于 2006-6-23 08:49 | 显示全部楼层

1. 只在奇数内循环

2. 利用已有的质数

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

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

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

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

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

TA的精华主题

TA的得分主题

发表于 2006-6-23 08:55 | 显示全部楼层

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

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2006-6-23 09:22 | 显示全部楼层

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

谢谢northwolves兄解释算法原理。

经测试,还是lotustower的最快!

TA的精华主题

TA的得分主题

发表于 2006-6-23 10:53 | 显示全部楼层

 优化一下:

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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-2-19 23:51 , Processed in 0.138548 second(s), 21 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表