Сколько их, простых

Option Explicit
Sub QuickSeekForPrimes()
'Программа отмечает в натуральном ряду (практически до 10^7—10^8) все простые числа
'и сообщает, сколько их имеется — до выбранного вами N.'
Const top As Variant = "100 000 000" ' "10 000 100"
If Not IsNumeric(Val(top)) Then MsgBox "Константа top должна быть числом.": Exit Sub
 
Dim tstart As Single, N, i, j, qP, approximation
N = Fix(Val(InputBox("До какого N?", "До N < 10 000 101 (больше — дольше!)", top)))
 
If N >= 1 And N < 10 ^ 8 + 101 Then
    ReDim flag(1 To N) As Long 'As Boolean экономил бы память - но это сужает диапазон
Else
    MsgBox "Измените N.", vbExclamation: Exit Sub
End If
 
approximation = Fix(N / (Log(N) - 1.08366)) - 2        'Legendre A. M. (Paris, 1808)
 
If N > 17 Then MsgBox "Expecting quantity of primes: " & approximation, vbInformation
 
            tstart = Timer 'засекли время начала выполнения программы
 
If N >= 2 Then
flag(2) = 1 'то есть «2 есть простое»'
qP = 1      'сосчитали первое простое число: 2'
End If
'Далее, для начала, берём все нечётные числа.'
For i = 3 To N Step 2: flag(i) = 1: Next i
 
For i = 3 To Sqr(N) Step 2 'Step 2, увы, только на 1% ускоряет поиск!'
    If flag(i) Then
        j = i ^ 2
            Do While j <= N
            flag(j) = 0 '«Вырубаем» каждое j-е число.'
            j = j + i
            Loop
    End If
Next i
'По сути, «просеяли» натуральный ряд через известное РЕШЕТО ЭРАТОСФЕНА.
For i = 3 To N: qP = qP + flag(i): Next
 
MsgBox "Среди чисел до " & N & " программа " & IIf(N < 2, "не ", "") & "нашла " & _
qP & IIf(Right(Str(qP), 1) = 1, " простое.", " простых.") & Chr(13) & Chr(13) _
& "Аппроксимация по Лежандру: " & approximation & Chr(10) _
& "Время выполнения " & Format(Timer - tstart, "0.000 с."), vbInformation
End Sub

Sub Eratosphene()
    Const n As Long = 535000100
    Dim a() As Byte, n2 As Long, i As Long, j As Long, k As Long, t As Single ', kc As Long, cntRows As Long
    n2 = (n - 1) \ 2
    'cntRows = Rows.Count
    ReDim a(1 To n2) As Byte ', b(1 To cntRows, 1 To 1) As Long
    
    t = Timer
    k = 1
    'kc = 1
    'b(1, 1) = 2
    For i = 1 To n2
        If a(i) = 0 Then
            k = k + 1
            'If k > cntRows Then
            '    Cells(1, kc).Resize(cntRows, 1) = b
            '    DoEvents
            '    k = 1
            '    kc = kc + 1
            '    ReDim b(1 To cntRows, 1 To 1) As Long
            'End If
            'b(k, 1) = i + i + 1
            If CDbl(i) * (i + 1) * 2 <= n2 Then For j = 2 * i * (i + 1) To n2 Step i + i + 1: a(j) = 1: Next j
        End If
    Next i
    'Cells(1, kc).Resize(k, 1) = b
    MsgBox "От 1 до " & n & vbLf & "Количество простых чисел: " & k & vbLf & _
            "Аппроксимация по Лежандру: " & Fix(n / (Log(n) - 1.08366)) & vbLf & _
            "Время работы - " & Format(Timer - t, "0.000 сек.")
End Sub

Option Explicit
 
Dim a() As Byte
 
Sub EratospheneBit()
    Const n As Double = 8000000000#
    Dim n2, i, j, k As Long, t As Single, t1 As Single, FileNumber As Long
    n2 = Fix((n - 1) / 2)
    ReDim a(Fix(n2 / 8)) As Byte
    
    t = Timer
    t1 = Timer
    FileNumber = FreeFile
    Open "output.txt" For Output As #FileNumber
    Print #FileNumber, "2"
    k = 1
    For i = 1 To n2
        If Not getBit(i) Then
            k = k + 1
            If Timer - t1 > 120 Then t1 = Timer: Debug.Print k, Format(1# + i + i, "0"), Format(Timer - t, "0.000 сек.")
            Print #FileNumber, Format(1# + i + i, "0")
            If 2# * i * (i + 1) <= n2 Then For j = 2 * i * (i + 1) To n2 Step i + i + 1: setBit j: Next j
        End If
    Next i
    Close #FileNumber
    MsgBox "От 1 до " & n & vbLf & "Количество простых чисел: " & k & vbLf & _
            "Аппроксимация по Лежандру: " & Fix(n / (Log(n) - 1.08366)) & vbLf & _
            "Время работы - " & Format(Timer - t, "0.000 сек.")
End Sub
 
Sub setBit(j)
    Dim i As Long
    i = Fix(j / 8)
    a(i) = a(i) Or Choose(j - i * 8# + 1, 1, 2, 4, 8, 16, 32, 64, 128)
End Sub
 
Function getBit(j) As Boolean
    Dim i As Long
    i = Fix(j / 8)
    getBit = (a(i) And Choose(j - i * 8# + 1, 1, 2, 4, 8, 16, 32, 64, 128)) > 0
End Function

Public Function ProstChisla(Max&) As Long()
    'Возврат списка простых чисел
    Dim i&, f&, d&
    ReDim b(Max) As Byte
    ReDim PCh&(Max \ 2)
    PCh(0) = 1
    PCh(1) = 2
    i = 1
    d = 1
    Do
      For f = PCh(i) To Max Step PCh(i) 'вычеркиваем кратные последнему простому
        b(f) = 1
      Next f
      
      For f = PCh(i) + d To Max Step 2 'ищем следующее простое число
        If b(f) = 0 Then i = i + 1: PCh(i) = f: Exit For
      Next f
      d = 2
    Loop Until f > Max
    ReDim Preserve PCh(i)
    ProstChisla = PCh
End Function

Function Primes(n&) As Long()
    Dim i&, j&, k&, a() As Byte, b&()
    If n < 2 Then Exit Function
    ReDim a(n) As Byte, b&(1 To Fix(n / Log(n) * 1.11) + 100)
 
    k = 1
    b(1) = 2
    For i = 3 To n Step 2
        If Not a(i) Then
            k = k + 1
            b(k) = i
            If CDbl(i) * i <= n Then For j = i * i To n Step i + i: a(j) = True: Next j
        End If
    Next i
    ReDim Preserve b&(1 To k)
    Primes = b
End Function

Function Primes2(n&) As Long()
    Dim i&, j&, k&, a() As Byte, b&()
    If n < 2 Then Exit Function
    ReDim a(1 To n) As Byte, b&(1 To Fix(n / Log(n) * 1.11) + 100)
    k = 1
    b(1) = 2
    For i = 3 To Int(Sqr(n)) Step 2
        If Not a(i) Then
            k = k + 1: b(k) = i
            For j = i * i To n Step i + i: a(j) = True: Next j
        End If
    Next i
    For i = i To n Step 2
        If Not a(i) Then k = k + 1: b(k) = i
    Next i
    ReDim Preserve b&(1 To k)
    Primes2 = b
End Function