Numeri PERFETTI

[albatros54Moderatore albatros54 Karma: 89 pts]

Oggi mio nipote rientrando dalla scuola << Nonno oggi la Professoressa di Matematica ha spiegato i numeri perfetti . Ha chiesto di scoprire quanti numeri Perfetti ci sono in un Range(1 to 10000) e quali sono, come posso trovarli?>> "Facile ho persato"  

Definizione"UN numero si dice PERFETTO, se è uguale alla somma dei suoi divisore diversi da se stesso"

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao, Purtoppo e ripeto PURTROPPO per motivi di lavoro mi hanno rimosso excel per passare a google sheets, un disastro....Pertanto lato macro lascio perdere,

Lato Formula, scrivendo i numeri da 1 a 10000 in colonna A con 1 in Riga 2 

=SE(MATR.SOMMA.PRODOTTO($A$2:A2;--(RESTO(A3;$A$2:A2)=0))=A3;"Trovato";"")

Oppure (matriciale)

=SE(SOMMA.PIÙ.SE($A$2:A2;RESTO(A3;$A$2:A2);"=0")=A3;"Trovato";"")

E poi Trascinare Verso il basso.

Nei Primo 1000 mi restituisce  6, 28, 496 ,8128

Ciao

Luca

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

@luca73
Ti sei dimenticato di dire che la formula va scritta in B3 e trascinata giù

[albatros54Moderatore albatros54 Karma: 89 pts]

Formule va bene, ma il post è stato postato nella sezione VBA, quindi sono bandite le formule  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

Prova...

Sub Perfetti()
Dim X As Long, Y As Long, ToT As Long, R As Long, Msg As String
R = 1
    For X = 2 To 10000
        Msg = "": ToT = 0
        For Y = 1 To X - 1
            If X Mod Y = 0 Then Msg = Msg & Y & "+": ToT = ToT + Y
        Next
        If ToT = X Then Cells(R, 1) = X & "=" & Left(Msg, Len(Msg) - 1): R = R + 1
    Next
MsgBox "fatto"
End Sub

[albatros54Moderatore albatros54 Karma: 89 pts]

Questo il mio codice

Option Explicit
Sub numeriperfetti() 'By Albatros54
    Dim myArray(1 To 10000)
    Dim f As Long
    Dim a As Long, b As Long
    Dim z As Long

    For f = LBound(myArray) To UBound(myArray)
        For a = 1 To f - 1
            b = f Mod a
            If b = 0 Then
                z = z + a
            End If
        Next
        If z = f Then
       
            MsgBox "Numero Perfetto   " & z
        End If
        z = 0
    Next
   
    MsgBox "Operazione Completata"
End Sub

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 ha scritto:

Ha chiesto di scoprire quanti numeri Perfetti ci sono in un Range(1 to 10000) e quali sono, come posso trovarli?

Bello. Questa la facciamo passare come una delle nostre Sfide periodiche. La intitoliamo "Sfida di quasi Halloween"   

[scossaPartecipante scossa Karma: 37 pts]

albatros54 ha scritto:

Questo il mio codice

intanto una piccola modifica al tuo codice, visto che i numeri perfetti saranno sempre pari tanto vale ciclare myArray a step di 2, dimezzando i tempi:

Sub numeriperfetti3() 'by scossa
'un numero si dice PERFETTO, se è uguale alla somma dei suoi divisore diversi da se stesso
    Dim f As Long
    Dim a As Long
    Dim z As Long
    Dim sRet As String

    For f = 2 To 10000 Step 2
      For a = 1 To f - 1
        If (f Mod a) = 0 Then z = z + a
      Next
      If z = f Then sRet = sRet & z & vbCrLf
      z = 0
    Next
    MsgBox "numeri perfetti:" & vbCrLf & sRet
End Sub

Edit: eliminato il superfluo (myArray e b).

[albatros54Moderatore albatros54 Karma: 89 pts]

scossa ha scritto:

intanto una piccola modifica al tuo codice

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

Ciao a tutti. proviamo a farlo anche per i numeri primi (divisibile solamente per 1 e per sé stesso)?

A parte il quesito, una domanda sui MSGBOX. Il msgbox (superata una "certa lunghezza", mette le parole accapo. Sarebbe possibile visualizzare questo messaggio in un'unica riga?
"Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao Ciao"

[scossaPartecipante scossa Karma: 37 pts]

Ciao,

quiz stimolante   

Propongo una sub che si basa parzialmente (*) sulla seguente caratteristica di un numero perfetto:

ha come espressione binaria p  valori uguali a uno seguiti da p−1  zeri (con p  numero primo)

(*) in questa versione non mi limito ai numeri primi.

La sub uPerfBin quindi genera una sequenza di numeri binari di n 1 seguiti da n-1 0 e li converte, tramite la udf fBin2Dec, in numeri decimali, quindi controlla tramite la udf fIsNumPerf  (tramite la udf fSigma che restituisce la somma dei divisori di un numero decimale) se il numero è un numero perfetto.

Sub uPerfBin()
  'by scossa
  'https://www.excelvba.it/forumexcel/forums/discussione/numeri-perfetti/
  
  Dim nUT As Double, nDummy As Double
  Dim sBin As String, sRet As String
  Dim vArr As Variant
  
  With Application
    For nUT = 1 To 13 '17 per arrivare al successivo: 8.589.869.056
      sBin = .Rept("1", nUT) & .Rept("0", nUT - 1)
      nDummy = fBin2Dec(sBin)
      If fIsNumPerf(nDummy) Then
        sRet = sRet & vbCr & nDummy
      End If
      DoEvents
    Next nUT
  End With
  sRet = Mid(sRet, 2)
  MsgBox "numeri perfetti:" & vbCr & sRet
  vArr = Split(sRet, vbCr)
  With ActiveCell.Resize(UBound(vArr) + 1, 1)
    .NumberFormat = "#,###"
    .Value = Application.Transpose(vArr)
  End With
End Sub

questa l'udf fIsNumPerf:

Function fIsNumPerf(ByVal nNum As Double) As Boolean
'by scossa
'un numero si dice PERFETTO, se è uguale alla somma dei suoi divisore diversi da se stesso
  fIsNumPerf = (fSigma(nNum) = nNum) And nNum > 0
End Function

questa l'udf fSigma:

Function fSigma(ByVal nNum As Double) As Double
'by scossa
'restituisce la somma dei divisori di nNum
  Dim j As Double

  For j = 1 To nNum - 1
    If (nNum - Int(nNum / j) * j) = 0 Then fSigma = fSigma + j
  Next

End Function

infine l'udf fBin2Dec (un classico della rete):

Function fBin2Dec(sBin As String) As Double
	Dim nDecValue As Double, i As Long
	For i = 0 To Len(sBin) - 1
	nDecValue = nDecValue + Mid(sBin, i + 1, 1) * (2 ^ (Len(sBin) - 1 - i))
	Next
	fBin2Dec = nDecValue
End Function

ovviamente si potrebbe inserire il codice delle tre udf dentro la sub ma queste udf sono utili anche per altri contesti.

N.B.: per nUT = 13 (25 bit: 13 uno + 12 zero) si trova 33,550,336, con nUT = 17 (33 bit: 17 uno + 16 zero) si trova 8.589.869.056 ma sul mio pc ha impiegato molti ma molti minuti; se qualche temerario, magari con un computer potente, volesse proseguire ....  io non mi assumo responsabilità .

[albatros54Moderatore albatros54 Karma: 89 pts]

puo valere questa soluzione  

Sub numeriprimiperfetti()    ' by Albatros54

    Dim nUT As Variant, nDummy As Double
    Dim sBin As String, sRet As String
    Dim vArr As Variant



    With Application

        For nUT = 1 To 20
            sBin = .Rept("1", nUT) & .Rept("0", nUT - 1)
            nDummy = fBin2Dec(sBin)

            primo = True
            'Quindi, per verificare se un numero  è primo è
            'sufficiente provare a dividerlo per tutti gli interi
            'minori di esso
            For a = 2 To nUT - 1
                If (nUT Mod a = 0) Then
                    primo = False
                End If
            Next
            If (primo = True) Then
                q = 2 ^ (nUT) - 1
                n = 2 ^ (nUT - 1) * q
                sRet = sRet & vbCr & n
                DoEvents
            End If
        Next
    End With
    MsgBox "numeri perfetti:" & vbCr & sRet
End Sub

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[scossaPartecipante scossa Karma: 37 pts]

albatros54 ha scritto:

puo valere questa soluzione

Esattamente! Era lo step successivo che stavo implementando, ma mi hai anticipato; bravo   

[Marius44Moderatore Marius44 Karma: 58 pts]

Salve a tutti

per @albatros

Certo che ottenere un "bravo" da @scossa è da incorniciare   

Ciao,

Mario

[gianfranco55Partecipante gianfranco55 Karma: 91 pts]

ciao

questi sono numeri perfetti

1- 23- 44- 45-47- 60

indovinate il perchè  

[albatros54Moderatore albatros54 Karma: 89 pts]

piccolo correzione, perchè  il Numero 11 pur essendo un numero primo non è

PERFETTO  

Sub numeriprimiperfetti()    ' by Albatros54

    Dim nUT As Variant, nDummy As Double, a As Double
    Dim sBin As String, sRet As String
    Dim vArr As Variant
    Dim primo As Boolean
    Dim Q As Double, N As Double


    With Application

        For nUT = 1 To 20
            sBin = .Rept("1", nUT) & .Rept("0", nUT - 1)
            nDummy = fBin2Dec(sBin)

            primo = True
            'Quindi, per verificare se un numero  è primo è
            'sufficiente provare a dividerlo per tutti gli interi
            'minori di esso
            For a = 2 To nUT - 1
                If (nUT Mod a = 0) Then
                    primo = False
                End If
            Next
            If (primo = True) Then
                MsgBox "numero primo  " & nUT
                'Proposizione 3.25. (Euclide)
                'Se Q = 2^p - 1 è primo (quindi p primo), allora N = 2^(p-1)*Q è un numero
                'perfetto.
                primo = True
                Q = 2 ^ (nUT) - 1
                c = (Q - 1)
                For p = 2 To c - 1
                    If (Q Mod p = 0) Then
                        primo = False
                    End If
                Next
                If (primo = True) Then
                N = 2 ^ (nUT - 1) * Q
                sRet = sRet & vbCr & N
                End If
                DoEvents
            End If
        Next
    End With
    MsgBox "numeri perfetti:" & vbCr & sRet
End Sub

Function fBin2Dec(sBin As String) As Double
    Dim nDecValue As Double, i As Long
    For i = 0 To Len(sBin) - 1
    nDecValue = nDecValue + Mid(sBin, i + 1, 1) * (2 ^ (Len(sBin) - 1 - i))
    Next
    fBin2Dec = nDecValue
End Function

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[albatros54Moderatore albatros54 Karma: 89 pts]

scossa ha scritto:

ma mi hai anticipato; bravo   

GRAZIE!!  

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Autore]

Articoli