[Bài tập VBA cho người rỗi rảnh] Hãy viết 1 macro tìm ra 3 số nguyên tố liên tiếp

[SA_DQ]

Ba số nguyên tố liên tiếp này bé hơn con số 999 & lớn hơn 100. (đã sửa sau góp ý của các bài 2 - 5)

Chúc các bạn vui vẻ nhân dịp xuân về!

 

[SA_DQ]

Mình lập 1 bảng các số nguyên tố như dưới đây & mong các bạn góp ý thêm:

Sub BangSoNguyenTo111_999()
 Dim Rw As Integer, Col As Integer, Num As Integer, Cot As Integer, RwMax As Integer
 ReDim Arr(1 To 50, 1 To 9) As Integer

 [A1].Resize(50, 9).Value = Space(0)
 For Num = 101 To 999 Step 2
    If IsPrime(Num) Then
        Col = Num \ 100
        If Col > Cot Then
            If Rw > RwMax Then RwMax = Rw
            Cot = Col:                  Rw = 1
        Else
            Rw = Rw + 1
        End If
        Arr(Rw, Col) = Num
    End If
 Next Num
 [A1].Resize(RwMax, 9).Value = Arr()
End Sub

Function IsPrime(n As Integer) As Boolean
 Dim i As Integer
 For i = 2 To Sqr(n)
    If n Mod i = 0 Then
        IsPrime = False:            Exit Function
    End If
 Next i
 IsPrime = True
End Function

 

[Châu Bá Thông]

Function IsPrime(n As Long) As Boolean
If n <= 1 Then
IsPrime = False
Exit Function
End If
If n = 2 Then
IsPrime = True
Exit Function
End If
If n Mod 2 = 0 Then
IsPrime = False
Exit Function
End If
For i = 3 To Int(Sqr(n)) Step 2
If n Mod i = 0 Then
IsPrime = False
Exit Function
End If
Next i
IsPrime = True
End Function

Sub FindConsecutivePrimes()
Dim primes() As Long
Dim count As Long
Dim n As Long
Dim i As Long
Dim ws As Worksheet
Dim outputRow As Long

' Chuẩn bị trang tính để xuất kết quả
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Cells.ClearContents
ws.Range("A1:C1") = Array("Prime 1", "Prime 2", "Prime 3")
outputRow = 2

' Tìm các số nguyên tố từ 101 đến 997
ReDim primes(1 To 1)
count = 0

For n = 101 To 997 Step 2
If IsPrime(n) Then
count = count + 1
If count > UBound(primes) Then ReDim Preserve primes(1 To count + 100)
primes(count) = n
End If
Next n

ReDim Preserve primes(1 To count)

' Kiểm tra và xuất các bộ ba số nguyên tố liên tiếp
If count < 3 Then
ws.Range("A2").Value = "Không tìm thấy bộ ba nào."
Exit Sub
End If

For i = 1 To count - 2
ws.Cells(outputRow, 1).Value = primes(i)
ws.Cells(outputRow, 2).Value = primes(i + 1)
ws.Cells(outputRow, 3).Value = primes(i + 2)
outputRow = outputRow + 1
Next i

MsgBox "Đã tìm thấy " & (count - 2) & " bộ ba số nguyên tố liên tiếp.", vbInformation
End Sub

 

[Châu Bá Thông]

Function IsPrime(n As Long, ByRef primes As Collection) As Boolean
Dim i As Long
Dim sq As Double

' Kiểm tra nhanh các trường hợp cơ bản
If n <= 1 Then
IsPrime = False
Exit Function
End If
If n = 2 Then
IsPrime = True
Exit Function
End If
If n Mod 2 = 0 Then
IsPrime = False
Exit Function
End If

' Kiểm tra chia hết với các số nguyên tố đã lưu
sq = Sqr(n)
For Each i In primes
If i > sq Then Exit For
If n Mod i = 0 Then
IsPrime = False
Exit Function
End If
Next i

' Nếu không chia hết thì là số nguyên tố
IsPrime = True
If IsPrime Then primes.Add n ' Thêm vào danh sách các số nguyên tố
End Function

Sub FindConsecutivePrimes()
Dim primes As New Collection
Dim n As Long
Dim i As Long
Dim ws As Worksheet
Dim outputRow As Long
Dim result As Variant
Dim idx As Long

' Chuẩn bị trang tính để xuất kết quả
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Cells.ClearContents
ws.Range("A1:C1").Value = Array("Prime 1", "Prime 2", "Prime 3")
outputRow = 2

' Tìm các số nguyên tố từ 101 đến 997
For n = 101 To 997 Step 2
Call IsPrime(n, primes)
Next n

' Xuất các bộ ba số nguyên tố liên tiếp
If primes.Count < 3 Then
ws.Range("A2").Value = "Không tìm thấy bộ ba nào."
Exit Sub
End If

ReDim result(1 To primes.Count - 2, 1 To 3)
For i = 1 To primes.Count - 2
result(i, 1) = primes(i)
result(i, 2) = primes(i + 1)
result(i, 3) = primes(i + 2)
Next i

ws.Range(ws.Cells(outputRow, 1), ws.Cells(outputRow + UBound(result, 1) - 1, 3)).Value = result

MsgBox "Đã tìm thấy " & (primes.Count - 2) & " bộ ba số nguyên tố liên tiếp.", vbInformation
End Sub

Bài đã được tự động gộp: Hôm qua, lúc 11:12

Thử lại

Function GeneratePrimes(maxNumber As Long) As Long()
    ' Tạo sàng Eratosthenes để lọc số nguyên tố đến maxNumber
    Dim sieve() As Boolean
    Dim primes() As Long
    Dim i As Long, j As Long, count As Long
    
    ReDim sieve(2 To maxNumber)
    For i = 2 To maxNumber
        sieve(i) = True
    Next i
    
    For i = 2 To Int(Sqr(maxNumber))
        If sieve(i) Then
            For j = i * i To maxNumber Step i
                sieve(j) = False
            Next j
        End If
    Next i
    
    ' Đếm số nguyên tố trong khoảng 101-999
    count = 0
    For i = 101 To maxNumber - 2  ' Đảm bảo có 3 số liên tiếp
        If sieve(i) And sieve(i + 2) And sieve(i + 4) Then
            count = count + 1
        End If
    Next i
    
    ' Lưu các bộ ba số nguyên tố liên tiếp
    ReDim primes(1 To count, 1 To 3)
    count = 0
    For i = 101 To maxNumber - 2
        If sieve(i) And sieve(i + 2) And sieve(i + 4) Then
            count = count + 1
            primes(count, 1) = i
            primes(count, 2) = i + 2
            primes(count, 3) = i + 4
        End If
    Next i
    
    GeneratePrimes = primes
End Function

Sub FindConsecutivePrimesOptimized()
    Dim primes() As Long
    Dim ws As Worksheet
    Dim startTime As Double
    
    startTime = Timer
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ws.Cells.ClearContents
    ws.Range("A1:C1") = Array("Prime 1", "Prime 2", "Prime 3")
    
    ' Tạo danh sách số nguyên tố và xuất kết quả
    primes = GeneratePrimes(999)
    
    If UBound(primes, 1) >= 1 Then
        ws.Range("A2").Resize(UBound(primes, 1), 3).Value = primes
        MsgBox "Tìm thấy " & UBound(primes, 1) & " bộ ba." & vbCrLf & _
               "Thời gian chạy: " & Format(Timer - startTime, "0.000") & " giây.", vbInformation
    Else
        MsgBox "Không tìm thấy bộ ba nào.", vbExclamation
    End If
End Sub