网页资讯视频图片知道文库贴吧地图采购
进入贴吧全吧搜索
excel吧 关注：280,814贴子：1,543,687

回复：求某数的质数因子

My computer too olded. So, I just set 10^4. You can try 10^6.
Sub primefinal()
Sheets("FINAL").Select
Dim rng As Range, arr()
Set rng = Range("b5").Resize(78500, 100)
arr = rng
Dim AP As Object: Set AP = Application
AP.EnableEvents = False
AP.Calculation = xlManual
Dim t1#, col%, r#
Dim num#, num_start#, num_end#, i#, i_end#
Dim lR As Long, lC As Long, lA As Long
Dim iA As Integer, TT
r = 2
TT = Timer
For col = 1 To 100
't1 = Timer
num_start = (col - 1) * 10 ^ 4 + 1
num_end = col * 10 ^ 4
For num = num_start To num_end Step 2
If num Mod 3 = 0 Then GoTo noprime
i_end = Int(num ^ 0.5 + 1)
For lC = 1 To 100
iA = 0
For lR = 1 To 78500
If arr(lR, lC) = 0 Or arr(lR, lC) > i_end Then
iA = iA + 1
Exit For
Else
If num Mod arr(lR, lC) = 0 Then GoTo noprime
End If
Next lR
If iA >= 1 Then Exit For
Next lC
For i = 6 To i_end Step 6
If num Mod (i - 1) = 0 Then GoTo noprime
If num Mod (i + 1) = 0 Then GoTo noprime
Next i
'addprime
r = r + 1
arr(r, col) = num
noprime:
Next num
'arr(1, col) = Timer - t1
r = 1
Next col
arr(2, 1) = 2
arr(3, 1) = 3
rng.Value = arr
AP.Calculation = xlAutomatic
AP.EnableEvents = True
MsgBox Timer - TT
End Sub


我等凡人只能颤抖了


Sub countP()
Dim t1 As Double, i As Long, row As Long, col As Long, sum As Long
Dim arr(100000000), rng As Range, result_arr()
n = 100000000
Set rng = Range("c1").Resize(100000, 100)
result_arr = rng
Dim AP As Object: Set AP = Application
AP.EnableEvents = False
AP.Calculation = xlManual
t1 = Timer
col = 3
row = 1
For i = 2 To Int(Sqr(n))
For j = i * i To n Step i
arr(j - 1) = 1
Next j
Next i
For i = 1 To n - 1
If arr(i) = 0 Then
sum = sum + 1
If row = 100001 Then
row = 1
col = col + 1
End If
result_arr(row, col) = i + 1
row = row + 1
End If
Next i
rng.Value = result_arr
AP.Calculation = xlAutomatic
AP.EnableEvents = True
Cells(1, 1) = sum
Cells(2, 1) = Timer - t1
End Sub


60s 左右就行了


用的是 埃拉托斯特尼筛法


@杰西米特瓦利亚
很神奇
我用六筛法拼入埃拉托斯特尼筛法竟然20秒内完成。
只修改了排除部份。


排列一亿以内质数，共5,761,455个。
本程序使用 [ 六筛法 ] 及 [ 埃拉托斯特尼筛法 ] 混合，
如圖片顯示，只耗時12秒左右，速度比前进一大步。
Sub PrimeSearch()
ActiveSheet.UsedRange.Offset(0, 2).ClearContents
Application.EnableEvents = False
Application.Calculation = xlManual
Dim t1#, N&, i&, j&, ix%, row&, col%
t1 = Timer
N = 100000000
Dim arr%(1 To 100000000)
result_arr = Range("c1").Resize(80000, 100)
For i = 2 To 3
For j = i ^ 2 To N Step i
arr(j) = 1
Next j
Next i
For i = 6 To Int(Sqr(N)) Step 6
For ix = -1 To 1 Step 2
For j = (i + ix) ^ 2 To N Step i + ix
arr(j) = 1
Next j
Next ix
Next i
For i = 2 To N
If arr(i) = 0 Then
If Int(i / 1000000) > col Then col = col + 1: row = 0
row = row + 1
result_arr(row, col + 1) = i
End If
Next i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1 & " s"
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub


增加2行，以堵塞六筛法的漏洞，我的电脑耗时少于12秒，如果电脑好可能在10秒以下。
增加:
If arr(i + ix) = 1 Then GoTo 888
888:


@siaojun哥 ,
把你中间的判断 2段合成了1段, 代码简洁了一点, 速度应该快了1s左右
Sub PrimeSearch()
ActiveSheet.UsedRange.Offset(0, 2).ClearContents
Application.EnableEvents = False
Application.Calculation = xlManual
Dim t1#, N&, i&, j&, ix%, row&, col%
t1 = Timer
N = 100000000
Dim arr%(1 To 100000000)
result_arr = Range("c1").Resize(80000, 100)
For i = 2 To Int(Sqr(N))
If arr(i) <> 1 Then
For j = i * i To N Step i
arr(j) = 1
Next j
End If
Next i
For i = 2 To N
If arr(i) = 0 Then
If Int(i / 1000000) > col Then col = col + 1: row = 0
row = row + 1
result_arr(row, col + 1) = i
End If
Next i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1 & " s"
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub


因为除了2 ,所有的偶数都不是素数,所以,我们可以把偶数直接跳过, 这个优化,能加快 1-2s
Sub PrimeSearch()
ActiveSheet.UsedRange.Offset(0, 2).ClearContents
Application.EnableEvents = False
Application.Calculation = xlManual
Dim t1#, N&, i&, j&, ix%, row&, col%
t1 = Timer
N = 100000000
Dim arr%(1 To 100000000)
result_arr = Range("c1").Resize(80000, 100)
For i = 3 To Int(Sqr(N)) Step 2
If arr(i) <> 1 Then
For j = i * i To N Step i
arr(j) = 1
Next j
End If
Next i
row = 1
result_arr(1, 1) = 2
For i = 3 To N Step 2
If arr(i) = 0 Then
If Int(i / 1000000) > col Then col = col + 1: row = 0
row = row + 1
result_arr(row, col + 1) = i
End If
Next i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1 & " s"
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub


每天有改进，今天我的电脑跌穿10秒。
上层楼程序依图示增加 *2

Sub prime_test()
ActiveSheet.UsedRange.Offset(0, 2).ClearContents
Application.EnableEvents = False
Application.Calculation = xlManual
Dim t1#, n&, i&, j&, row&, col%
t1 = Timer
n = 100000000
Dim arr%(2 To 100000000)
Dim result_arr(1 To 80000, 1 To 100)
For i = 3 To Int(Sqr(n)) Step 2
If arr(i) <> 1 Then
For j = i * i To n Step i * 2
arr(j) = 1
Next j
End If
Next i
row = 1
result_arr(1, 1) = 2
For i = 3 To n Step 2
If arr(i) = 0 Then
If Int(i / 1000000) > col Then col = col + 1: row = 0
row = row + 1
result_arr(row, col + 1) = i
End If
Next i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub


@siaojun哥 我在网上看到还有速度更快的筛法: 线性欧拉筛
但是我用vb 实现了它的代码之后,速度反而不如 我们这个, 你看看能否改进
Sub prime_test()
ActiveSheet.UsedRange.Offset(0, 2).ClearContentsApplication.EnableEvents = FalseApplication.Calculation = xlManual
Dim t1#, n&, i&, j&, row&, col%t1 = Timern = 100000000Dim arr%(2 To 100000000)Dim result_arr(1 To 80000, 1 To 100)
'--------欧拉筛--------------
Dim prime&(1 To 10000000), x&x = 0For i = 3 To n Step 2 If arr(i) = 0 Then x = x + 1 prime(x) = i End If For j = 1 To x If i * prime(j) <= n Then arr(i * prime(j)) = 1 If i Mod prime(j) = 0 Then Exit For Else Exit For End If Next jNext i'----------------------------------
'--------埃拉托斯特尼筛--------------
' For i = 3 To Int(Sqr(n)) Step 2' If arr(i) <> 1 Then' For j = i * i To n Step i * 2' arr(j) = 1' Next j' End If' Next i'-----------------------------------
row = 1result_arr(1, 1) = 2
For i = 3 To n Step 2If arr(i) = 0 ThenIf Int(i / 1000000) > col Then col = col + 1: row = 0row = row + 1result_arr(row, col + 1) = iEnd IfNext i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1Application.Calculation = xlAutomaticApplication.EnableEvents = True
End Sub


Sub prime_test()
ActiveSheet.UsedRange.Offset(0, 2).ClearContents
Application.EnableEvents = False
Application.Calculation = xlManual
Dim t1#, n&, i&, j&, row&, col%
t1 = Timer
n = 100000000
Dim arr%(2 To 100000000)
Dim result_arr(1 To 80000, 1 To 100)
'--------欧拉筛--------------
Dim prime&(1 To 10000000), x&
x = 0
For i = 3 To n Step 2
If arr(i) = 0 Then
x = x + 1
prime(x) = i
End If
For j = 1 To x
If i * prime(j) <= n Then
arr(i * prime(j)) = 1
If i Mod prime(j) = 0 Then Exit For
Else
Exit For
End If
Next j
Next i
'----------------------------------
'--------埃拉托斯特尼筛--------------
' For i = 3 To Int(Sqr(n)) Step 2
' If arr(i) <> 1 Then
' For j = i * i To n Step i * 2
' arr(j) = 1
' Next j
' End If
' Next i
'-----------------------------------
row = 1
result_arr(1, 1) = 2
For i = 3 To n Step 2
If arr(i) = 0 Then
If Int(i / 1000000) > col Then col = col + 1: row = 0
row = row + 1
result_arr(row, col + 1) = i
End If
Next i
Range("c1").Resize(80000, 100).Value = result_arr
Cells(2, 1) = Timer - t1
Application.Calculation = xlAutomatic
Application.EnableEvents = True
End Sub


1亿还是太小 ，数字再大一些 欧拉筛的优势才能体现


但是vb似乎不支持很大的整数


扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！
分享到: