[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: Thứ ba 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

 

[Châu Bá Thông]

Thử lại lần cuối, tùy chọn vùng kiểm tra minNumber (>=2), maxNumber do người dùng tự quyết định, ví dụ này là minNumber = 101, maxNumber =999

Function GeneratePrimes(minNumber as Long, maxNumber As Long) As Long()
    ' Tạo sàng Eratosthenes để lọc số nguyên tố đến maxNumber
    Dim sieve() As Boolean
    Dim primesList() As Long
    Dim tripletArray() As Long
    Dim i As Long, j As Long
    Dim primeCount As Long, tripletCount As Long
   
    ' Khởi tạo sàng
    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
   
    ' Lọc các số nguyên tố trong khoảng minNumber-maxNumber
    primeCount = 0
    For i = minNumber To maxNumber
        If sieve(i) Then primeCount = primeCount + 1
    Next i
   
    If primeCount = 0 Then
        GeneratePrimes = Array()
        Exit Function
    End If
   
    ' Lưu vào mảng primesList
    ReDim primesList(1 To primeCount)
    primeCount = 0
    For i = minNumber To maxNumber
        If sieve(i) Then
            primeCount = primeCount + 1
            primesList(primeCount) = i
        End If
    Next i
   
    ' Tìm các bộ ba liên tiếp trong danh sách
    tripletCount = 0
    For i = 1 To primeCount - 2
        tripletCount = tripletCount + 1
    Next i
   
    If tripletCount = 0 Then
        GeneratePrimes = Array()
        Exit Function
    End If
   
    ' Lưu kết quả vào mảng 2D
    ReDim tripletArray(1 To tripletCount, 1 To 3)
    For i = 1 To tripletCount
        tripletArray(i, 1) = primesList(i)
        tripletArray(i, 2) = primesList(i + 1)
        tripletArray(i, 3) = primesList(i + 2)
    Next i
   
    GeneratePrimes = tripletArray
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")
   
    primes = GeneratePrimes(101,999)   '****
   
    If Not IsEmpty(primes) 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

 

[SA_DQ]

TẠO BẢNG 100 SỐ NGUYÊN TỐ GỒM 3 KÝ SỐ LỚN NHẤT.​

Sub TaoBang100SoNguyenTo3ChuSoLonNhat()
 Dim Num As Integer, Col As Integer, Cot As Integer, Rw As Integer, Dem As Integer
 ReDim Arr(1 To 30, 1 To 9) As String:              Dim RwMax As Integer
 
 Sheet2.Select
 [B2].Resize(30, 9).Value = Arr():                  Cot = 9
 For Num = 999 To 101 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) = CStr(Num):                   Dem = Dem + 1
        If Dem = 100 Then
            [B2].Resize(RwMax, 9).Value = Arr():    Exit Sub
        End If
    End If
 Next Num
End Sub

Hàm IsPrime(Num) đã có ở #21.

 

[DeTong]

Thêm giải pháp Query:
1. Tạo 1 function để kiếm tra 1 số xem có thỏa là số nguyên tố không? --> True/false

//fNguyenTo
(so as number) as logical =>

let
   kq=  List.Count(List.Select({2..Number.RoundDown(Number.Sqrt(so))}, each Number.Mod(so, _) = 0 )) = 0
in
   kq

2. Dùng List.Generate ( tương tự vòng lặp for trong vba ) để duyệt từ 997 xuống mỗi lần trừ 2, nếu true thì gán vào List,
3. Lấy n số từ đầu danh sách bằng List.FirstN

let
    // thay vong lap FOR
    a = List.Generate(
        () => 997,
        each _ > 100,
        each _ - 2,
        each if fNguyenTo(_) then _ else null),
  
    // Lay 20 ket qua dau tien
    kq = List.FirstN(List.RemoveNulls(a), 20)

in
    kq

 

[HieuCD]

Góp vui code tìm số nguyên tố

Sub xyz()
  Dim a(1 To 1000), res(1 To 1000, 1 To 1)
  Dim xMin&, xMax&, xU, i&, j&, k&, n&
 
  xMin = 100: xMax = 9999
  For i = xMin To 2
    n = n + 1:      res(n, 1) = i
  Next i
'Tao mang cac so nguyen to lam co so so sanh
  xU = Int(Sqr(xMax))
  For i = 3 To xU Step 2
    For j = 1 To k
      If i Mod a(j) = 0 Then Exit For
    Next j
    If j > k Then
      k = k + 1:  a(k) = i
      If i >= xMin Then n = n + 1:  res(n, 1) = i
    End If
  Next i

  If n > 0 Then
    If xMin < res(n, 1) Then xMin = res(n, 1) + 1
  End If
  xMin = ((xMin \ 2) * 2 + 1) 'Lay gia tri le
 
  For i = xMin To xMax Step 2
    For j = 1 To k
      If i Mod a(j) = 0 Then Exit For
    Next j
    If j > k Then n = n + 1: res(n, 1) = i
  Next i
  Range("B2").Resize(UBound(res), 1) = res
End Sub

 

[VetMini]

Có VBA, có Query rồi. Bi giờ ai xung phong viết hàm Lambda hôn?