Разложение на простые множители

Sub lb8()
Dim r, c, k, cc, Arr(), n, a As Variant
 
    r = ActiveCell.Row
    c = ActiveCell.Column
 
Do
   a = Val(InputBox("a = "))
   If a = 0 Then Exit Do
   n = n + 1
   ReDim Preserve Arr(1 To n)
   Arr(n) = a
Loop
 
    For Each k In Arr
        Cells(r, c).Value = k
        cc = c + 1
        
        For j& = 2 To k \ 2 + 1
        
            If (rnm(j&)) And (k Mod j& = 0) Then
               Cells(r, cc).Value = j&
               cc = cc + 1
            End If
            
        Next j&
        r = r + 1
    Next
End Sub
 
Function rnm(n As Long) As Boolean
     If n = 2 Then
        rnm = True
     Else
        If n Mod 2 = 0 Then
           rnm = False
        Else
         rnm = True
           For i& = 3 To Sqr(n) Step 2
               If n Mod i& = 0 Then
                rnm = False
                  Exit For
               End If
           Next i&
        End If
    End If
End Function

Option Explicit
 
Sub start()
    Dim n, result, i&, s$
    
    n = InputBox("Введите целое число")
    If IsNumeric(n) Then
        result = RazlozhenieNaMnozhiteli(Abs(Fix(n)))
        s = "Множители числа " & n & ":"
        For i = 0 To UBound(result)
            s = s & vbLf & result(i)
        Next
        MsgBox s
    End If
    
End Sub
 
 
Function RazlozhenieNaMnozhiteli(ByVal Num As Double)
    Dim p, i&, j&, r()
    p = Primes(Num): j = -1
    
 
    For i = UBound(p) To 0 Step -1
 
        If Num Mod p(i) = 0 Then
            Do
                Num = Num / p(i)
                j = j + 1
                ReDim Preserve r(j): r(j) = p(i)
            Loop While Num Mod p(i) = 0 And i > 1
        End If
    Next
 
    RazlozhenieNaMnozhiteli = r
    
End Function
 
Function Primes(ByVal max&) As Long()
    Dim i&, ii&, n&
    
    If max > 1 Then
    ElseIf max = 1 Then
        ReDim ll&(0): ll(0) = 1: Primes = ll: Exit Function
    Else: Exit Function
    End If
 
    ReDim b(max) As Byte, ll&(Fix(max / Log(max) * 2))
    n = 1
    ll(0) = n: ll(n) = 2
    For i = 3 To Fix(Sqr(max)) Step 2
        If Not b(i) Then
            n = n + 1: ll(n) = i
            For ii = i * i To max Step i + i: b(ii) = True: Next
        End If
    Next i
    For i = i To max Step 2
        If Not b(i) Then n = n + 1: ll(n) = i
    Next i
    ReDim Preserve ll&(n): Primes = ll
End Function

Sub lb8()
Dim r, c, k, cc, Arr(), n, a As Variant
 
    r = ActiveCell.Row
    c = ActiveCell.Column
 
Do
   a = Val(InputBox("a = "))
   If a = 0 Then Exit Do
   n = n + 1
   ReDim Preserve Arr(1 To n)
   Arr(n) = a
Loop
 
.......
 
End Sub

Sub lb8()
Dim r, c, k, cc, Arr(), n, a As Variant
  
       r = ActiveCell.Row
       c = ActiveCell.Column
 
 Do
       a = Val(InputBox("a = "))
       If a = 0 Then Exit Do
       n = n + 1
       ReDim Preserve Arr(1 To n)
       Arr(n) = a
 Loop
 
 For Each k In Arr
        Cells(r, c).Value = k
        cc = c + 1
        For j& = 2 To k \ 2 + 1
        Next j&
        r = r + 1
 Next
 
  Cells(1, 2) = Application.WorksheetFunction.UDF_MNOJITELI(A1)
 
 
End Sub
Function UDF_MNOJITELI(chislo)
    Dim i As Integer, del As String
    i = 2
    While chislo > 1
        While chislo Mod i = 0
            del = del & "*" & i
            chislo = chislo / i
        Wend
        i = i + 1
    Wend
    UDF_MNOJITELI = Mid(del, 2)
End Function

Sub mm2()
start2 6 * 31 + 1
start2 6 * 31 - 1
start2 6 * 31
start2 6 * 37 + 1
start2 6 * 37 - 1
start2 6 * 37
start2 2 ^ 10
''Множители числа 187:1 11 17
''Множители числа 185:1 5 37
''Множители числа 186:1 2 3 31
''Множители числа 223:1 223
''Множители числа 221:1 13 17
''Множители числа 222:1 2 3 37
''Множители числа 1024:1 2 2 2 2 2 2 2 2 2 2
End Sub
Sub start2(npar)
Dim n, s$, k1, k1k
n = npar
If IsNumeric(n) Then
    n = Abs(Fix(n))
    s = "Множители числа " & n & ":1"
    k1k = Sqr(n)
    k1 = 2
    Do While k1 < k1k
        If n Mod k1 = 0 Then
        s = s & " " & k1
        n = n / k1
        Else
        k1 = k1 + 1
        End If
    Loop
    Debug.Print s; IIf(n = 1, "", n)
End If
End Sub