Perfect Number

[maor1212]

Hii,

Perhaps there is something you can help me with though?
I have to write an order in VBA to find the next perfect number

please help me

[maor1212]

My number currently is 28

[si_the_geek]

Welcome to VBForums

Thread moved from the 'VB.Net' forum to the 'Office Development/VBA' forum.

[Leith Ross]

Hello maor1212,

Sub PerfectNumbers()

    ' Algorithm by John Knoderer at The Math Forum
    ' Adapted to VBA by Leith Ross
    ' http://mathforum.org/dr.math/faq/faq.perfect.html
    
    ' // Perfect numbers derived from Mersenne prime numbers.
    For Each pM In Array(2, 3, 5, 7, 13, 17, 19, 31)
        pN = 2 ^ (pM - 1) * (2 ^ pM - 1)
       MsgBox pN, vbOKOnly, "Perfect Numbers"
    Next pM
    
End Sub

[vbfbryce]

Or, the long way:

Sub findPerf()
    Dim ws As Worksheet
    Dim J As Long
    Dim K As Long
    Dim nums() As Long
    Dim cnt As Long
    Dim tot As Long
    Dim perfects() As Long
    Dim pCnt As Long
    Dim myMax As Long
    
    Set ws = ActiveSheet
    With ws
        myMax = 49999   'set to something like 8500 if you want
        pCnt = -1
        For J = 1 To myMax
            tot = 0
            cnt = -1
            For K = 2 To J - 1
                If J Mod K = 0 Then
                    cnt = cnt + 1
                    ReDim Preserve nums(cnt)
                    nums(cnt) = K
                    tot = tot + K
                End If
            Next K
                If tot + 1 = J Then
                    pCnt = pCnt + 1
                    ReDim Preserve perfects(pCnt)
                    perfects(pCnt) = tot + 1
                End If
        Next J
        For J = 0 To pCnt
            .Range("b" & J + 1).Value = perfects(J)
        Next J
    End With
End Sub

[OptionBase1]

Or, the long way:

Your "For K" loop can be improved by stopping at the greatest possible relevant value:

For K = 2 To J \ 2

[maor1212]

Hello maor1212,

Sub PerfectNumbers()

    ' Algorithm by John Knoderer at The Math Forum
    ' Adapted to VBA by Leith Ross
    ' http://mathforum.org/dr.math/faq/faq.perfect.html
    
    ' // Perfect numbers derived from Mersenne prime numbers.
    For Each pM In Array(2, 3, 5, 7, 13, 17, 19, 31)
        pN = 2 ^ (pM - 1) * (2 ^ pM - 1)
       MsgBox pN, vbOKOnly, "Perfect Numbers"
    Next pM
    
End Sub

I am sorry if I didn't explain myself well
I have a range ("a1") [28] in excel, I have to find the next perfect with using VBA

[maor1212]

I am sorry if I didn't explain myself well
I have a range ("a1") [28] in excel, I have to find the next perfect with using VBA

[maor1212]

I wrote this code but it doesn't work

Sub riddle()
Dim no As Integer

Dim sum As Integer

Dim I As Integer
no = Range("a1") +1 // range ("a1") =28 so it start from the next number
yes= range("a1")
while no <> yes

For i = 1 To no

If no Mod i = 0 Then

sum = sum + i

End If

Next i
If sum / 2 = no Then

yes = no
Else

no=no+1

End If

wend

range("b1")=yes
End Sub

[westconn1]

do you want to calculate the next perfect number or just add it to the cell from a list of perfect numbers, which within the range of vb variables would be quite small

you can use the code posted by leith to calculate the next perfect number
the result from his code, from which you can also have a list of perfect number

6
28
496
8128
33550336
8589869056
137438691328
2.30584300813995E+18

[maor1212]

do you want to calculate the next perfect number or just add it to the cell from a list of perfect numbers, which within the range of vb variables would be quite small

you can use the code posted by leith to calculate the next perfect number
the result from his code, from which you can also have a list of perfect number

I need that VBA calculate the next perfect number
for example if cell a1 = 28 then cell a2= 496 or if a1 =496 then a2=8128 - by calculating

[DEXWERX]

Well, since everyone's already posted an answer...

Public Function NextPerfect(ByVal Prev As Double) As Double
    Dim CurDouble As Double
    Dim CurTotal As Double
    Dim CurPerfect As Double
    
    CurDouble = 1
    CurTotal = 1
    Do While CurPerfect <= Prev
        CurDouble = CurDouble * 2
        CurTotal = CurTotal + CurDouble
        If IsPrime(CurTotal) Then
            CurPerfect = CurDouble * CurTotal
        End If
    Loop
    NextPerfect = CurPerfect
End Function

Public Function IsPrime(ByVal Number As Double) As Boolean
    Dim i As Double
    
    If Number <= 1 Or (Number - Int(Number)) <> 0 Then
        Exit Function
    ElseIf Number <= 3 Then
        IsPrime = True
        Exit Function
    ElseIf (Number Mod 2 = 0) Or (Number Mod 3 = 0) Then
        Exit Function
    End If
    i = 5
    Do While i * i <= Number
        If (Number Mod i = 0) Or (Number Mod (i + 2) = 0) Then
            Exit Function
        End If
        i = i + 6
    Loop
    IsPrime = True
End Function

[vbfbryce]

Good catch! I had that in there at one point, somehow didn't end up in my post!

(Responding to post 6)