Test Foro de elhacker.net SMF 2.1

Antes que nada:
http://es.wikipedia.org/wiki/N%C3%BAmero_de_la_suerte

La función ha de recibir el numero (LONG) y devolver True o False (BOOLEAN) en caso de que sea o no un numero de la suerte

El reto es a ver quien consigue hacer la comprobacion mas rapida :)
Es un reto similar a este (http://foro.elhacker.net/programacion_visual_basic/snippetreto_isitprime_comprobar_si_un_numero_es_primo-t298929.0.html), pero las propiedades de los numeros de la suerte son distintas


Suerte, y yo voy a preparar ahora mi codigo :)

¿Como medimos el tiempo?  :huh: Interesante propuesta, me pongo a ello  ;D.

Saludos

Cita de: [Zero] en 11 Agosto 2010, 01:12 AM
¿Como medimos el tiempo?  :huh: Interesante propuesta, me pongo a ello  ;D.

Saludos

http://www.xbeat.net/vbspeed/download/CTiming.zip
http://www.xbeat.net/vbspeed/details.htm#How I Time

Lo mas seguro es que si puede Seba revise los tiempos, es recomendable hacer todas las pruebas desde el mismo PC :D

¿Pero sólo se puede en VB o puedes medir mi código en ASM?

Saludos

El algoritmo se las trae!! Despues de casi una hora he conseguido una version que no optimizada al maximo... aqui esta:
Option Explicit
Option Base 1

Public Static Function IsItLucky(ByVal lNumb As Long) As Boolean
   Dim bvSieve()   As Byte
   Dim lJump       As Long
   Dim lLastNumb   As Long
   Dim i           As Long
   Dim iCount      As Long
   Dim xCount      As Long
   Dim x           As Long
   
   If lNumb = 1 Or lNumb = 3 Then IsItLucky = True: Exit Function
   
   If (lNumb And 1 = 0) Then Exit Function
   
   If lJump = 0 Then lJump = 2
   
   If lLastNumb < lNumb Then
       ReDim Preserve bvSieve(lNumb)
       
       iCount = 0
       xCount = 1
       
       Do
           For i = 1 To lNumb
               If bvSieve(i) = False Then iCount = iCount + 1
               If iCount = lJump Then
                   bvSieve(i) = True
                   iCount = 0
               End If
           Next i
           iCount = 0
           xCount = xCount + 1
           For i = 1 To lNumb
               If bvSieve(i) = False Then
                   x = x + 1
                   If x = xCount Then
                       lJump = i
                       x = 0
                       Exit For
                   End If
               End If
           Next i
       Loop Until xCount > lJump
   End If
   
   IsItLucky = Not bvSieve(lNumb)
   
   lLastNumb = lNumb
End Function


---

Cita de: [Zero] en 11 Agosto 2010, 02:09 AM
¿Pero sólo se puede en VB o puedes medir mi código en ASM?

Saludos

Si consigues hacerlo en ASM tranquilo que sabras como medir el tiempo con QueryPerformanceCounter >:D  :xD :xD
:laugh: :laugh: :laugh: :laugh: :laugh: :laugh: :laugh: :laugh: :laugh: No son horas para estar por el foro... madre mia.. habia creado el tema en A&D de Malware, mejor sera que me vaya a dormir :-[  :laugh: :laugh: :laugh:

He probado tu código, pero me da mal los resultados,
1, 3, 7, 9, 13, 15, 21, 25, 31, 33, 37, 43, 49, 51, 63, 67, 69, 73, 75, 79, 87, 93, 99...

A la primera vez si intentas con 1,3,7,9,13, el 15 no sale, y si vuelves a intentar algún numero no da, no se si me expliqué, pero no funca bien.

Trabajo ahora en el mio :D

SaluDOS!!!

me uno aqui pondre el mio!¡.

P.D.: Esta algo canijo xP...

Ducles Lunas!¡.

bueno para quemar algunas neuras (quedan poquitas  >:() , no testie la velocidad pero me conformo con que ande  ;D


Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long
    Dim c As New Collection

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
        c.Add lPos
    Next

    lCount = 1

    Do While c.Count > lCount

        lCount = lCount + 1
        lPos = c(lCount)

        Do
            If lPos > c.Count Then Exit Do
            c.Remove lPos
            lPos = lPos + c(lCount) - 1
        Loop

        If c(c.Count) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


uso:

Private Sub Form_Load()
   Dim i As Long
   Dim s As String
   For i = 1 To 200
       If IsLuckyNumber(i) Then
           s = s & i & " "
       End If
   Next
   Debug.Print s
End Sub

Saludos.

Me apunto!!!  :D

DoEvents¡! :P

Bueno, ya lo tengo... :D

CitarEl algoritmo se las trae!!

Ya te digo, me costó bastante... :-\

Traigo DOS formas de hacerlo:

1ª Forma:
Es como yo lo haría, que mas "chulo" con Collections:

Option Explicit

Public Function Check_Lucky_Number(ByVal lNumber As Long) As Boolean
   Dim cTemp                   As New Collection
   Dim NextElim                As Long
   Dim m                       As Long
   Dim x                       As Long
   
   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       With cTemp
           For x = 1 To lNumber Step 2
               .Add x
           Next
           NextElim = 3 : m = 2
           Do
               x = NextElim
               Do While x <= .Count
                   .Remove (x)
                   x = x + (NextElim - 1)
               Loop
               If .Item(.Count) = lNumber Then
                   m = m + 1
                   NextElim = .Item(m)
               Else
                   Exit Function
               End If
           Loop While Not NextElim > .Count
       End With
IsLucky: Check_Lucky_Number = True
   End If
End Function

2ª Forma:
Aqui utilizo un Array:


Option Explicit
Public Function Check_Lucky_Number2(ByVal lNumber As Long) As Boolean
   Dim lTempArray()            As Long
   Dim NextElim                As Long
   Dim m                       As Long
   Dim x                       As Long
   
   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       m = 1
       For x = 1 To lNumber Step 2
           ReDim Preserve lTempArray(m)
           lTempArray(m) = x
           m = m + 1
       Next
       NextElim = 3 : m = 2
       Do
           x = NextElim
           Do While x <= UBound(lTempArray)
               Call Delete_Array_Item(lTempArray, x)
               x = x + (NextElim - 1)
           Loop
           If lTempArray(UBound(lTempArray)) = lNumber Then
               m = m + 1
               NextElim = lTempArray(m)
           Else
               Exit Function
           End If
       Loop While Not NextElim > UBound(lTempArray)
IsLucky: Check_Lucky_Number2 = True
   End If
End Function
' Esto lo hace MUY lento... :( Mirar sig version en la pág siguiente ;)
Private Sub Delete_Array_Item(ByRef lArray() As Long, ByVal lIndex As Long)
   Dim lCount      As Long
   Dim x           As Long
   
   lCount = UBound(lArray)
   If lIndex <= lCount And lIndex >= LBound(lArray) Then
       For x = lIndex To lCount - 1
           lArray(x) = lArray(x + 1)
       Next
       ReDim Preserve lArray(lCount - 1)
   End If
End Sub

---

Para probarlas:
Private Sub Form_Load()
   Dim x           As Long
   Dim sResult     As String
   
   For x = 1 To 200
       'If Check_Lucky_Number2(x) Then
       If Check_Lucky_Number(x) Then
           sResult = sResult & x & " "
       End If
   Next
   Debug.Print sResult
End Sub

Ambas me devuelven esto:

Citar1 3 7 9 13 15 21 25 31 33 37 43 49 51 63 67 69 73 75 79 87 93 99 105 111 115 127 129 133 135 141 151 159 163 169 171 189 193 195

DoEvents¡! :P

Me he tomado la libertad de ir testeando, aunque habria que probarlo en más PCs...
Utilizando:
cTiming.cls (http://www.xbeat.net/vbspeed/download/CTiming.zip)

Private tmr     As CTiming

Option Explicit
Option Base 1

'Karcrack
Public Static Function IsItLucky(ByVal lNumb As Long) As Boolean
    Dim bvSieve()   As Byte
    Dim lJump       As Long
    Dim lLastNumb   As Long
    Dim i           As Long
    Dim iCount      As Long
    Dim xCount      As Long
    Dim x           As Long

    If lNumb = 1 Or lNumb = 3 Then IsItLucky = True: Exit Function

    If (lNumb And 1 = 0) Then Exit Function

    If lJump = 0 Then lJump = 2

    If lLastNumb < lNumb Then
        ReDim Preserve bvSieve(lNumb)

        iCount = 0
        xCount = 1

        Do
            For i = 1 To lNumb
                If bvSieve(i) = False Then iCount = iCount + 1
                If iCount = lJump Then
                    bvSieve(i) = True
                    iCount = 0
                End If
            Next i
            iCount = 0
            xCount = xCount + 1
            For i = 1 To lNumb
                If bvSieve(i) = False Then
                    x = x + 1
                    If x = xCount Then
                        lJump = i
                        x = 0
                        Exit For
                    End If
                End If
            Next i
        Loop Until xCount > lJump
    End If

    IsItLucky = Not bvSieve(lNumb)

    lLastNumb = lNumb
End Function

'*PsYkE1*
Public Function Check_Lucky_Number(ByVal lNumber As Long) As Boolean
    Dim cTemp                   As New Collection
    Dim NextElim                As Long
    Dim m                       As Long
    Dim x                       As Long

    If lNumber = 1 Or lNumber = 3 Then
        GoTo IsLucky
    ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
        With cTemp
            For x = 1 To lNumber Step 2
                .Add x
            Next
            NextElim = 3: m = 2
            Do
                x = NextElim
                Do While x <= .Count
                    .Remove (x)
                    x = x + (NextElim - 1)
                Loop
                If .Item(.Count) = lNumber Then
                    m = m + 1
                    NextElim = .Item(m)
                Else
                    Exit Function
                End If
            Loop While Not NextElim > .Count
        End With
IsLucky: Check_Lucky_Number = True
    End If
End Function

' LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long
    Dim c As New Collection

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
        c.Add lPos
    Next

    lCount = 1

    Do While c.Count > lCount

        lCount = lCount + 1
        lPos = c(lCount)

        Do
            If lPos > c.Count Then Exit Do
            c.Remove lPos
            lPos = lPos + c(lCount) - 1
        Loop

        If c(c.Count) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function

Private Sub Form_Load()
    Dim x           As Long
    Dim sResult     As String
   
    Set tmr = New CTiming
    tmr.Reset
   
    For x = 1 To 500
        If IsLuckyNumber(x) Then ' Aqui los voy probando uno a uno... :P
            sResult = sResult & x & " "
        End If
    Next
    MsgBox tmr.sElapsed
   
    Debug.Print sResult
End Sub

---

Mis resultados:

LeandroA: 28,734
Karcrack : 69,309
*PsYkE1* : 19,923

DoEvents¡! :P

Jajajajaja...! *PsYkE1* te has vuelto un adicto al Collection...!

Excelente trabajo...! Me gustó..!

Mi codigo todavia no es funcional, tiene varios fallos, por ejemplo, en la segunda llamada da errores, debido a que dejo las variables llenas de basura... a ver si consigo mañana algo de tiempo y hago la version raaaapida :P

Buen trabajo Psyke, veo que has exprimido al maximo las neuronas, a mi me dejo con dolor de cabeza :xD, tanto tiempo sin pensar... :-[ :laugh:

Cita de: ssccaann43 en 12 Agosto 2010, 18:22 PM
Jajajajaja...! *PsYkE1* te has vuelto un adicto al Collection...!

Excelente trabajo...! Me gustó..!

Jajajajajaja  :laugh: :laugh:
Eso es por culpa de Karcrack!  :silbar: :xD
Él me volvió adicto... ;)

Cita de: Karcrack en 12 Agosto 2010, 23:53 PM
Mi codigo todavia no es funcional, tiene varios fallos, por ejemplo, en la segunda llamada da errores, debido a que dejo las variables llenas de basura... a ver si consigo mañana algo de tiempo y hago la version raaaapida :P

Buen trabajo Psyke, veo que has exprimido al maximo las neuronas, a mi me dejo con dolor de cabeza :xD, tanto tiempo sin pensar... :-[ :laugh:

Gracias¡! :D
Si te digo la verdad, en un momento me pareció tan desesperante que pense en mandarlo a la m****a... :xD
Aun asi el reto me gustó, de paso planteo una pregunta:
Esto que hemos hecho tiene alguna utilidad?¿ :huh:

DoEvents¡! :P

Bueno, como se dijo, no me impota el tiempo, me conformo con que funcione... espero ...porque la verdad es que me costó un huevo (el izquierdo). :xD ,  lo dicho con que funcione está bien para mí.



Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub Form_Load()
 
   
    Dim t1 As Long
    Dim t2 As Long
    t1 = GetTickCount
 
    Me.AutoRedraw = True
   
    Me.Print IsLucky(45235)
   
    t2 = GetTickCount
   
    Me.Print t2 - t1
   
   
   
End Sub

Function IsLucky(lngNum As Long) As Boolean

Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As String

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
If lngNum = 5 Then Exit Function


For x = 1 To lngNum Step 2
      ReDim Preserve numLuck(contStep)
      numLuck(contStep) = x
      contStep = contStep + 1
Next

contStep = 0: cont = 0: Indice = 1

While numLuck(Indice) <= UBound(numLuck)
  For x = 0 To UBound(numLuck)
      If cont = numLuck(Indice) - 1 Then
        cont = 0
      Else
        numLuck(contStep) = numLuck(x)
        cont = cont + 1
        contStep = contStep + 1
      End If
  Next
  If contStep = numLuck(Indice + 1) Then
    ReDim Preserve numLuck(contStep - 2)
  Else
    ReDim Preserve numLuck(contStep - 1)
  End If
  cont = 0
  contStep = 0
  Indice = Indice + 1
Wend

For x = 0 To UBound(numLuck)
If numLuck(x) = lngNum Then
   IsLucky = True
   Exit For
End If
Next

End Function




Hola Dessa!!

He mirado el code, puedes ganar un poco de velocidad si haces esto:
If numLuck(UBound(numLuck)) = lngNum Then IsLucky = True

En vez de esto:
For x = 0 To UBound(numLuck)
If numLuck(x) = lngNum Then
  IsLucky = True
  Exit For
End If
Next

Teniendo en cuenta que el número que buscas siempre estara el ultimo,y te evitas recorrer tooooooodo el array, mas tarde lo miro con mas detenimiento que tengo prisa...

DoEvents¡! :P

Aca otra version mas rapida de la mia pero sin collection y con array. esta utiliza CopyMemory segun como esta aqui (http://www.leandroascierto.com.ar/foro/index.php?topic=105.msg406#msg406)


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    For lPos = 1 To Num Step 2
         i = i + 1
         ReDim Preserve Arr(i)
         Arr(i) = lPos
    Next

    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


a con esto es mas rapido


    ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


Oops LeandroA, nuestras funciones van practicamente igual de rapido...  :o

DoEvents¡! :P

Leandro, probando como dice Karcrack (que devuelva un Boolean ingresando un numero Long) es un "Misil", muy buena, no era que las matematicas no eran tu fuerte ?



PsYkE1, si en teoria tenes razon, pero probando no cambia en mucho, después pruebo mejor, me quedó la cabeza "quemada"  :xD

Cita de: Dessa en 13 Agosto 2010, 12:57 PM
Leandro, probando como dice Karcrack (que devuelva un Boolean ingresando un numero Long) es un "Misil", muy buena, no era que las matematicas no eran tu fuerte ?

:o
Oh dios!!
Es verdad, va como un tiro!! ;-)
Las Collections son mas apropiadas cuando se trabaja con poca cantidad de Items... :-\
Por eso acabo de hacer esta tercera versión, es la mas rápida de las mias, y de velocidad anda pareja con la de LeandroA  :rolleyes::

Option Explicit
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)

Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
   Dim lTempArray()            As Long
   Dim NextElim                As Long
   Dim lArrayUBound            As Long
   Dim m                       As Long
   Dim x                       As Long

   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       m = 1
       For x = 1 To lNumber Step 2
           ReDim Preserve lTempArray(m)
           lTempArray(m) = x
           m = m + 1
       Next
       NextElim = 3: m = 2
       Do
           x = NextElim
           Do While x <= UBound(lTempArray)
               lArrayUBound = UBound(lTempArray)
               If Not x = lArrayUBound Then
                   RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                   ReDim Preserve lTempArray(lArrayUBound - 1)
               Else
                   Exit Function
               End If
               x = x + (NextElim - 1)
           Loop
           m = m + 1
           NextElim = lTempArray(m)
       Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
   End If
End Function

Testeado con GetTickCount:

CitarLeandroA IsLuckyNumber ---> 125
PsyKe1 Check_Lucky_Number3 ---> 125

:¬¬ :xD

---

@Dessa
Me referia a que hicieses algo asi:
Option Explicit

Function IsLucky2(lngNum As Long) As Boolean
   Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As String
   
   If lngNum < 1 Or lngNum Mod 2 = 0 Or lngNum = 5 Then Exit Function
   If lngNum = 1 Or lngNum = 3 Then IsLucky2 = True: Exit Function
   
   For x = 1 To lngNum Step 2
         ReDim Preserve numLuck(contStep)
         numLuck(contStep) = x
         contStep = contStep + 1
   Next
   contStep = 0: cont = 0: Indice = 1
   While numLuck(Indice) <= UBound(numLuck)
     For x = 0 To UBound(numLuck)
         If cont = numLuck(Indice) - 1 Then
           cont = 0
         Else
           numLuck(contStep) = numLuck(x)
           cont = cont + 1
           contStep = contStep + 1
         End If
     Next
     If contStep = numLuck(Indice + 1) Then ReDim Preserve numLuck(contStep - 2) Else ReDim Preserve numLuck(contStep - 1)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
      cont = 0
     contStep = 0
     Indice = Indice + 1
   Wend
   
   IsLucky2 = True
End Function

IsLucky : 147,75 ms
IsLucky2 : 87,45 ms

---

@Karcrack
Una duda con tu code:
If (lNumb And 1 = 0) Then Exit Function
Esto para que es?¿  :huh:
Es como hacer Mod?¿

---

DoEvents¡! :P

Puff, me descuido un dia y me dejais completamente atras :-[, ya os descuidareis y despertare a todas mis neuronas muahahahhaha! >:D :xD

@Psyke: Es para comprobar que sea par, es muchiiiisimo mas rapido que hacer un Mod, es lo que te dije, trabajar con Bits :P

Hola a todos:

No pude evitar hacer un código después de ver el ímpetu que demuestran.

Hice un código que recibe un número y despliega un mensaje, informando si ese número es o no es de la suerte. El mensaje también muestra el tiempo transcurrido en realizar las operaciones; muestra el tiempo antes de iniciar las operaciones, el tiempo después de realizar las operaciones y por último, la diferencia entre ambos, es decir, el tiempo total empleado en realizar las operaciones.

Sólo lo probé con los números del 1 al 37, ya que me dió flojera probar con más números.

Pero bueno, se necesita un cuadro de texto Text1 y un botón de comando Command1. El código es el siguiente:


Option Explicit

Private Sub Command1_Click()
Dim esdesuerte As Boolean
Dim t1 As Long, t2 As Long, tdif As Long
    t1 = timeGetTime()
    esdesuerte = verifnum(Val(Text1.Text))
    t2 = timeGetTime()
    tdif = t2 - t1
    If esdesuerte = False Then
        MsgBox ("El número " & Val(Text1.Text) & " no es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    Else
        MsgBox ("El número " & Val(Text1.Text) & " es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    End If
End Sub

Private Function verifnum(ByVal num As Long) As Boolean
Dim bufA(33000) As Long
Dim bufB(33000) As Long
Dim indElim As Long
Dim iniciales As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long
   
    If num Mod 2 = 0 Then
        verifnum = False
        Exit Function
    End If
   
    indElim = 2
    iniciales = 1
    i = 1
    Do While iniciales <= num
        bufA(i) = iniciales
        iniciales = iniciales + 2
        i = i + 1
    Loop
    i = i - 1
   
    If indElim >= i Then
        verifnum = True
    Else
        Do
            indElim = bufA(indElim)
            If indElim > i Then
                verifnum = True
                Exit Function
            End If
            i_auxA = indElim
            While i_auxA <= i
                If bufA(i_auxA) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufA(i_auxA) = bufA(i_auxA) * -1
                i_auxA = i_auxA + indElim
            Wend
       
            i_auxA = 1
            i_auxB = 1
            While i_auxA <= i
                If bufA(i_auxA) > 0 Then
                    bufB(i_auxB) = bufA(i_auxA)
                    i_auxB = i_auxB + 1
                End If
                i_auxA = i_auxA + 1
            Wend
            i = i_auxB - 1
       
            indElim = bufB(indElim)
            If indElim > i Then
                verifnum = True
                Exit Function
            End If
            i_auxB = indElim
            While i_auxB <= i
                If bufB(i_auxB) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufB(i_auxB) = bufB(i_auxB) * -1
                i_auxB = i_auxB + indElim
            Wend
           
            i_auxA = 1
            i_auxB = 1
            While i_auxB <= i
                If bufB(i_auxB) > 0 Then
                    bufA(i_auxA) = bufB(i_auxB)
                    i_auxA = i_auxA + 1
                End If
                i_auxB = i_auxB + 1
            Wend
            i = i_auxA - 1
        Loop
    End If
End Function


Y en el módulo el código es el siguiente:


Option Explicit

Public Declare Function timeGetTime Lib "winmm.dll" () As Long

En fín, si alguien quiere hacerme el favor de revisarlo  para números arriba del 37 se los agradeceré. Es que es demasiado fastidioso estar generando a mano los números de la suerte.

                    Saludos

Cita de: Karcrack en 13 Agosto 2010, 22:01 PM
Puff, me descuido un dia y me dejais completamente atras :-[, ya os descuidareis y despertare a todas mis neuronas muahahahhaha! >:D :xD

@Psyke: Es para comprobar que sea par, es muchiiiisimo mas rapido que hacer un Mod, es lo que te dije, trabajar con Bits :P

Jajajajaja :laugh:
Tengo ganas de ver tu nueva version, pero espero que no quedemos todos empate... :¬¬ :silbar: :xD
@Tokes

No te ofendas, pero tu codigo esta bastante desorganizado, pon el codigo entre
[ code=vb ] aqui tu codigo [ /code ] 'Sin espacios
El code es demasiado largo y lento... :-\

Citar

Código [Seleccionar] Expandir

Dim bufA(33000) As Long
Dim bufB(33000) As Long

o_O
Aún asi creo que te esforzaste... ;)

DoEvents¡! :P

Si Pyske1   , te entendí pero probé 45235 (compilado), con gettickcount y las dos van parejas... por supuesto que tendría que ser mas rapida con tu sugerencia (sin el último For). intentaré mejorar con RtlMoveMemory  :D

Cita de: Tokes en 13 Agosto 2010, 22:22 PM
En fín, si alguien quiere hacerme el favor de revisarlo  para números arriba del 37 se los agradeceré.

Tokes, el 45 lo da como true y no lo es, tambien entre 1 y 200 hay 8 numeros mas que no son Lucky, saludos







   

@Dessa
Creo que ya se por que no hay apenas diferencia:
Al utilizar tu metodo para contar el tiempo solo tienes que realizar una comprobacion, pero probandolo de esta otra manera (http://foro.elhacker.net/programacion_visual_basic/reto_comprobar_si_un_numero_dado_es_un_numero_de_la_suerte-t301960.0.html;msg1497950#msg1497950) si que se nota la diferencia porque tiene que hacer 500 comprobaciones... :rolleyes:
Lo ideal es probar la funcion de las dos maneras... ;)

---

@Karcrack

Private Sub Form_Load()
   Dim x As Long
   For x = 0 To 10000
       If (x And 1 = 0) Then MsgBox "Funciona"
   Next
End Sub
:silbar:

DoEvents¡! :P

Bueno, he hecho una pequeña correción en el código y queda así. Me parece que ahora si da los números bien y es un poquitín más rápido.

Se necesitan 2 command buttons (Command1 y Command2) y textbox Text1 y una label Label1. El Command1 dice si el número del Text1 es de la suerte. El command2 da los números de la suerte desde el 1 hasta el especificado en Text1.

La Label1 debe ser un tantito grande para que le quepan todos los números.
La función que verifica si el número es de la suerte se llama verifnum.

Option Explicit

Private Sub Command1_Click()
Dim esdesuerte As Boolean
Dim t1 As Long, t2 As Long, tdif As Long
    t1 = timeGetTime()
    esdesuerte = IsLucky2(Val(Text1.Text))
    t2 = timeGetTime()
    tdif = t2 - t1
    If esdesuerte = False Then
        MsgBox ("El número " & Val(Text1.Text) & " no es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    Else
        MsgBox ("El número " & Val(Text1.Text) & " es de la suerte" _
        & Chr(13) & "t1 = " & t1 & Chr(13) & "t2 = " & t2 & Chr(13) _
        & "Tiempo = " & tdif)
    End If
End Sub

Private Function verifnum(ByVal num As Long) As Boolean
Dim bufA() As Long
Dim bufB() As Long
Dim indElim As Long
Dim ordenElim As Long
Dim iniciales As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long


    If (num And 1) = 0 Then
        verifnum = False
        Exit Function
    End If
   
    ReDim bufA(0 To num)
    ReDim bufB(0 To num)
    ordenElim = 2
    iniciales = 1
    i = 1
    Do While iniciales <= num
        bufA(i) = iniciales
        iniciales = iniciales + 2
        i = i + 1
    Loop
    i = i - 1
   
        Do
            If ordenElim >= i Then
                verifnum = True
                Exit Function
            End If
            indElim = bufA(ordenElim)
            ordenElim = ordenElim + 1
            i_auxA = indElim
            While i_auxA <= i
                If bufA(i_auxA) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufA(i_auxA) = 0
                i_auxA = i_auxA + indElim
            Wend
       
            i_auxA = 1
            i_auxB = 1
            While i_auxA <= i
                If bufA(i_auxA) > 0 Then
                    bufB(i_auxB) = bufA(i_auxA)
                    i_auxB = i_auxB + 1
                End If
                i_auxA = i_auxA + 1
            Wend
            i = i_auxB - 1
       
            If ordenElim >= i Then
                verifnum = True
                Exit Function
            End If
            indElim = bufB(ordenElim)
            ordenElim = ordenElim + 1
            i_auxB = indElim
            While i_auxB <= i
                If bufB(i_auxB) = num Then
                    verifnum = False
                    Exit Function
                End If
                bufB(i_auxB) = 0
                i_auxB = i_auxB + indElim
            Wend
           
            i_auxA = 1
            i_auxB = 1
            While i_auxB <= i
                If bufB(i_auxB) > 0 Then
                    bufA(i_auxA) = bufB(i_auxB)
                    i_auxA = i_auxA + 1
                End If
                i_auxB = i_auxB + 1
            Wend
            i = i_auxA - 1
        Loop
    'End If
End Function

Private Sub Command2_Click()
Dim strvis As String
Dim i As Long
Dim t1 As Long, t2 As Long
    t1 = timeGetTime
    strvis = "Los números de la suerte entre el 1 y el " & Text1.Text & " son:" & Chr(13)
    If verifnum(1) = True Then
        strvis = strvis & CStr(1)
    End If
    For i = 2 To Text1.Text
        If verifnum(i) = True Then
            strvis = strvis & ", " & Str(i)
        End If
    Next i
    t2 = timeGetTime
    strvis = strvis & Chr(13) & "Tiempo = " & t2 - t1
    'MsgBox (strvis)
    Label1 = strvis
End Sub

Y el código del módulo es:

Option Explicit

Public Declare Function timeGetTime Lib "winmm.dll" () As Long

Bueno, el código es un poco largo pero me parece que va un poquitín más rápido.

Ahi va mi aporte, perdon por la descarga pero es un poco grande para pegar aca.
Posiblemente no sea tan rapido como otros que vi por aca porque priorice el uso de memoria (simplemente por gusto) en vez de utilizar un array de longs como vi que usaban muchos me parecio mas entretenido hacer algo diferente, asi que utilice un array de bytes que a su vez los utilizo como array de bits para guardar 8 valores por byte, lo malo de hacerlo de esta manera es que hay que recorrer el array para encontrar los indices pero trate de optimizarlo un poco, por ejemplo el loop principal utiliza un tercio de las iteraciones que vi que los demas utilizan y otras cositas mas.

[http://cobein.com/shares/LuckyNumbs.rar]

Edit: Me olvide de quitar un pedazo de codigo que estaba utilizando... nada importante pero aca pego uno mas limpio.

Private Function TestNum(ByVal lVal As Long) As Boolean
   
   If lVal < 1 Then Exit Function
   If Not lVal And 1 Then Exit Function
   
   mBitArray.AllocateBuffer lVal
   
   Dim i As Long
   For i = 1 To lVal Step 6
       mBitArray.SetValue i, True
       mBitArray.SetValue i + 2, True
   Next
   
   Dim lIncrement As Long
   Dim lPos As Long
   
   lPos = 3
   Dim lRet As Long
   
   Do
       lIncrement = mBitArray.FindPositive(lPos)
       If lIncrement = -1 Then Exit Do
       lRet = 1
       Do
           lRet = mBitArray.FindPositive(lIncrement, lRet) 'Save the last pos to not loop from start
           If lRet = -1 Then Exit Do
           mBitArray.SetValue lRet, False
       Loop
       If Not FindPositiveRev(1) = lVal Then Exit Function
       lPos = lPos + 1
   Loop
   If FindPositiveRev(1) = lVal Then TestNum = True
       
End Function

No se si es una forma chapucera de hacerlo pero asi de una forma rapido fue k se me ocurrio con arrays se k ess mas facil con los collection pero esa es la norma con los arrays pense k con un par de arrays anidados se podia como hice algo en la escuela una vez pero no tenia vastante tiempo haci k esta es la forma mas facil k pude hacerlo pork no tengo destrezas con usar datos en memoria jeje

Public Function LuckyNumber(ByVal N As Long) As Boolean
       Dim ANumero()    As Long
       Dim AText1()       As Long
       Dim i                   As Integer
       Dim X                  As Integer        
       
       i = 1
       X = 1
       If N Mod 2 = 0 Then Exit Function  

       For i = 1 To N Step 2
          ANumero(X) = i
          X = X + 1
       Next
       For i = 0 To UBound(ANumero) Step 3
           If ANumero(i) = N Then Exit Function
           ANumero(i) = 0
       Next
       X = 1
       For i = 1 To UBound(ANumero)
            If ANumero(i) <> 0 Then
               AText1(X) = ANumero(i)
               X = X + 1
            End If
       Next
       For i = 0 To UBound(AText1) Step 7
           If AText1(i) = N Then Exit Function            
       Next
       
       LuckyNumber = True
       
End Function

No se si es muy rapida pero funciona bien  ;D

@Angeldj27
No funciona bien me da varios errores en las matrices, y solo haces tres bucles para quitar numeros el resultado no sera correcto, leete bien el link que puso karcrack al principio... ;)

DoEvents¡! :P

Pude mejorar en parte a mi primera version, bueno, algo es algo...

Tambien me queda pendiente la sugerencia de Psyke.




Option Explicit
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
 
 If App.LogMode = 0 Then
   MsgBox "Ejecutar Compilado"
   End ' perdon por el end
 End If
 
   Dim t1 As Long
   Dim t2 As Long
 
   Me.AutoRedraw = True
   
   t1 = GetTickCount
   Me.Print IsLucky(45235) & "  IsLucky"
   t2 = GetTickCount
   Me.Print t2 - t1

End Sub
Function IsLucky(lngNum As Long) As Boolean

Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As Long

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
If lngNum = 5 Then Exit Function


For x = 1 To lngNum Step 2
     ReDim Preserve numLuck(contStep)
     numLuck(contStep) = x
     contStep = contStep + 1
Next

contStep = 0: cont = 0: Indice = 1

While numLuck(Indice) <= UBound(numLuck)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
     x = -1
     While x < UBound(numLuck)
         x = x + 1
         If cont = numLuck(Indice) - 1 Then
             cont = 0
         Else
           numLuck(contStep) = numLuck(x)
           cont = cont + 1
           contStep = contStep + 1
         End If
   Wend

   If contStep = numLuck(Indice + 1) Then
       ReDim Preserve numLuck(contStep - 2)
   Else
       ReDim Preserve numLuck(contStep - 1)
   End If
   cont = 0
   contStep = 0
   Indice = Indice + 1
Wend

For x = 0 To UBound(numLuck)
   If numLuck(x) = lngNum Then
     IsLucky = True
     Exit For
   End If
Next

End Function




Señores, he corregido mi código. Finalmente pude hacer la función un tanto más compacta y más rápida que la primera y la segunda versión que hice. Les dejo el código (la función se llama verifnum3 porque es el tercer intento que hice):

Private Function verifnum3(ByVal num As Long) As Boolean
Dim bufA() As Long
Dim indElim As Long
Dim indElim_aux As Long
Dim ordenElim As Long
Dim iniciales As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long


    If (num And 1) = 0 Then
        Exit Function
    End If
   
    ReDim bufA(0 To num)
    ReDim bufB(0 To num)
    ordenElim = 2
    iniciales = 1
    i = 1
    Do While iniciales <= num
        bufA(i) = iniciales
        iniciales = iniciales + 2
        i = i + 1
    Loop
    i = i - 1
   
    If ordenElim >= i Then
        verifnum3 = True
        Exit Function
    End If
       
    Do
        indElim = bufA(ordenElim)
        ordenElim = ordenElim + 1
        If indElim > i Then
            verifnum3 = True
            Exit Function
        End If
        If bufA(indElim) = num Then Exit Function
        i_auxA = indElim
        i_auxB = indElim + 1
        Do
            For indElim_aux = 2 To indElim
                If i_auxB > i Then Exit Do
                bufA(i_auxA) = bufA(i_auxB)
                i_auxA = i_auxA + 1
                i_auxB = i_auxB + 1
            Next indElim_aux
            If i_auxB = i Then Exit Function
            i_auxB = i_auxB + 1
        Loop
        i = i_auxA - 1
    Loop
End Function

Cita de: *PsYkE1* en 14 Agosto 2010, 19:33 PM
@Angeldj27
No funciona bien me da varios errores en las matrices, y solo haces tres bucles para quitar numeros el resultado no sera correcto, leete bien el link que puso karcrack al principio... ;)

DoEvents¡! :P

Talvez hay que definirle un numero fijo a la dimencion del array o matrix pero es raro me funciona bien y con lo k dices, voy eliminando numeros como dice el link de karcrack y chekeo la matriz y si el numero no esta hay se supone k no es numero de la suerte es simple logica ami me funciona de 10

Mira, te pongo un ejemplo:

 Dim x As Long
 Dim s As String
 For x = 5000 To 5500
   'If Check_Lucky_Number3(x) Then
   If LuckyNumber(x) Then
       s = s & x & " "
   End If
 Next
 Debug.Print s
Me devuelve:

Citar5001 5005 5007 5011 5013 5019 5023 5025 5029 5031 5035 5041 5043 5047 5049 5053 5055 5061 5065 5067 5071 5073 5077 5083 5085 5089 5091 5095 5097 5103 5107 5109 5113 5115 5119 5125 5127 5131 5133 5137 5139 5145 5149 5151 5155 5157 5161 5167 5169 5173 5175 5179 5181 5187 5191 5193 5197 5199 5203 5209 5211 5215 5217 5221 5223 5229 5233 5235 5239 5241 5245 5251 5253 5257 5259 5263 5265 5271 5275 5277 5281 5283 5287 5293 5295 5299 5301 5305 5307 5313 5317 5319 5323 5325 5329 5335 5337 5341 5343 5347 5349 5355 5359 5361 5365 5367 5371 5377 5379 5383 5385 5389 5391 5397 5401 5403 5407 5409 5413 5419 5421 5425 5427 5431 5433 5439 5443 5445 5449 5451 5455 5461 5463 5467 5469 5473 5475 5481 5485 5487 5491 5493 5497

Cuando deberia devolver:

Citar5001 5007 5019 5029 5041 5043 5049 5053 5089 5103 5127 5137 5139 5149 5151 5157 5169 5179 5181 5191 5211 5217 5229 5233 5235 5253 5259 5277 5283 5293 5295 5299 5325 5335 5341 5343 5371 5377 5379 5385 5409 5419 5427 5433 5449 5455 5463 5473 5487 5491

---

@Dessa
No pense que fuera a cambiar tanto el resultado... :o
Ahora pruebalo asi:
Private Sub Form_Load()
   Dim x As Long
   Dim s As String
   Dim t1 As Long
   Dim t2 As Long
 
   If App.LogMode = 0 Then End
   Me.AutoRedraw = True
   
   'Dessa
   Me.Print "Dessa"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLucky(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   
   MsgBox s
   s = ""
   
   '*PsYkE1*
   Me.Print "PsYkE1"
   t1 = GetTickCount
   For x = 5000 To 7000
       If Check_Lucky_Number3(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   MsgBox s
   
   'LeandroA
   Me.Print "LeandroA"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLuckyNumber(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1
   MsgBox s
End Sub

Mis resultados:

Dessa          2265
*PsYkE1*   1860
LeandroA    1984

:rolleyes:

DoEvents¡! :P

mmm me parece que estas tomando mal mi función yo tengo estos resultados

Dessa
2125

PsYkE1
2000

LeandroA
1172

pongo las tres funciones


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
    Dim x As Long
    Dim s As String
    Dim t1 As Long
    Dim t2 As Long

    If App.LogMode = 0 Then End
    Me.AutoRedraw = True

    'Dessa
    Me.Print "Dessa"
    t1 = GetTickCount
    For x = 5000 To 7000
        If IsLucky(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1 & vbNewLine

    MsgBox s
    s = ""

    '*PsYkE1*
    Me.Print "PsYkE1"
    t1 = GetTickCount
    For x = 5000 To 7000
        If Check_Lucky_Number3(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1 & vbNewLine
    MsgBox s

    'LeandroA
    Me.Print "LeandroA"
    t1 = GetTickCount
    For x = 5000 To 7000
        If IsLuckyNumber(x) Then
            s = s & x & " "
        End If
    Next
    t2 = GetTickCount
    Me.Print t2 - t1
    MsgBox s
End Sub

'Dessa
Function IsLucky(lngNum As Long) As Boolean

  Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As Long

  If lngNum < 1 Then Exit Function
  If lngNum Mod 2 = 0 Then Exit Function
  If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
  If lngNum = 5 Then Exit Function


  For x = 1 To lngNum Step 2
      ReDim Preserve numLuck(contStep)
      numLuck(contStep) = x
      contStep = contStep + 1
  Next

  contStep = 0: cont = 0: Indice = 1

  While numLuck(Indice) <= UBound(numLuck)
      x = -1
      While x < UBound(numLuck)
          x = x + 1
          If cont = numLuck(Indice) - 1 Then
              cont = 0
          Else
            numLuck(contStep) = numLuck(x)
            cont = cont + 1
            contStep = contStep + 1
          End If
    Wend
 
    If contStep = numLuck(Indice + 1) Then
        ReDim Preserve numLuck(contStep - 2)
    Else
        ReDim Preserve numLuck(contStep - 1)
    End If
    cont = 0
    contStep = 0
    Indice = Indice + 1
  Wend

  For x = 0 To UBound(numLuck)
    If numLuck(x) = lngNum Then
      IsLucky = True
      Exit For
    End If
  Next

End Function




'-PsYkE1
Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
    Dim lTempArray()            As Long
    Dim NextElim                As Long
    Dim lArrayUBound            As Long
    Dim m                       As Long
    Dim x                       As Long

    If lNumber = 1 Or lNumber = 3 Then
        GoTo IsLucky
    ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
        m = 1
        For x = 1 To lNumber Step 2
            ReDim Preserve lTempArray(m)
            lTempArray(m) = x
            m = m + 1
        Next
        NextElim = 3: m = 2
        Do
            x = NextElim
            Do While x <= UBound(lTempArray)
                lArrayUBound = UBound(lTempArray)
                If Not x = lArrayUBound Then
                    RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                    ReDim Preserve lTempArray(lArrayUBound - 1)
                Else
                    Exit Function
                End If
                x = x + (NextElim - 1)
            Loop
            m = m + 1
            NextElim = lTempArray(m)
        Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
    End If
End Function

'LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

    ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


Saludos

LA de cobein aun se esta ejecutando, en un siguiente Post pongo el resultado con el de este por que su funcion es ESAGERADAMENTE LENTA ( me tardo 1 minuto, actualmente se esta combrobando las coherencias. )!¡.

No se por que demonios pero por hay creo que Spyke y Dessa andan mal o quisas sea Leandro?

Lo siguiente comprueba Tiempo y coherencias entre las tres funciones, LeandroA difiere con Spyke y Dessa en algunos numeros, aqui mostrados!¡.



Dessa --> 2625
PsYkE1 -- > 2094
LeandroA -- > 1359

Se comprobaran Coherencias...

LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5179
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5191
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5299
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5335
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5371
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5419
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5455
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5491
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5503
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5515
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5527
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5551
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5587
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5599
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5671
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5707
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5719
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5755
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5767
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5803
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5827
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5839
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5851
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5911
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5923
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5959
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 5971
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6019
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6031
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6055
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6079
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6115
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6163
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6175
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6211
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6271
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6331
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6355
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6367
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6379
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6415
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6427
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6463
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6475
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6523
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6535
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6559
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6631
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6667
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6679
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6715
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6763
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6787
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6871
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6883
LeandroA (Falso) ;  Dessa (Verdadero) ;   PsYkE1 (Verdadero)   --> 6931



Dulces Lunas!¡.

Aqui el proyecto de comprobacion!¡.

http://infrangelux.sytes.net/filex/down.php?InfraDown=/BlackZeroX/ComprobacionVel.zip





Dessa --> 2625
PsYkE1 -- > 2078
LeandroA -- > 1375
Cobein -- > 108015

Se comprobaran Coherencias...

LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5179
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5191
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5299
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5335
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5371
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5419
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5455
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5491
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5503
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5515
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5527
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5551
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5587
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5599
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5671
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5707
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5719
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5755
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5767
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5803
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5827
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5839
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5851
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5911
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5923
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5959
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 5971
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6019
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6031
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6055
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6079
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6115
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6163
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6175
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6211
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6271
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6331
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6355
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6367
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6379
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6415
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6427
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6463
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6475
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6523
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6535
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6559
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6631
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6667
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6679
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6715
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6763
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6787
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6871
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6883
LeandroA (Falso) ;   Dessa (Verdadero) ;   PsYkE1 (Verdadero) ;   Cobein (Verdadero) ; --> 6931



Dulces Lunas!¡.

Yo olvidé de agregar un If a mi code, luego pruebo como dice  BlackZeroX , por ahora serà así



Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
   Dim x As Long
   Dim s As String
   Dim t1 As Long
   Dim t2 As Long

   If App.LogMode = 0 Then End
   Me.AutoRedraw = True

   'Dessa
   Me.Print "Dessa"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLucky(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine

   MsgBox s
   s = ""

   '*PsYkE1*
   Me.Print "PsYkE1"
   t1 = GetTickCount
   For x = 5000 To 7000
       If Check_Lucky_Number3(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   MsgBox s

   'LeandroA
   Me.Print "LeandroA"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLuckyNumber(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1
   MsgBox s
End Sub

'Dessa
Function IsLucky(lngNum As Long) As Boolean

Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As Long

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
If lngNum = 5 Then Exit Function


For x = 1 To lngNum Step 2
     ReDim Preserve numLuck(contStep)
     numLuck(contStep) = x
     contStep = contStep + 1
Next

contStep = 0: cont = 0: Indice = 1

While numLuck(Indice) <= UBound(numLuck)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
     x = -1
     While x < UBound(numLuck)
         x = x + 1
         If cont = numLuck(Indice) - 1 Then
             cont = 0
         Else
           numLuck(contStep) = numLuck(x)
           cont = cont + 1
           contStep = contStep + 1
         End If
   Wend

   If contStep = numLuck(Indice + 1) Then
       ReDim Preserve numLuck(contStep - 2)
   Else
       ReDim Preserve numLuck(contStep - 1)
   End If
   cont = 0
   contStep = 0
   Indice = Indice + 1
Wend

For x = 0 To UBound(numLuck)
   If numLuck(x) = lngNum Then
     IsLucky = True
     Exit For
   End If
Next

End Function




'-PsYkE1
Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
   Dim lTempArray()            As Long
   Dim NextElim                As Long
   Dim lArrayUBound            As Long
   Dim m                       As Long
   Dim x                       As Long

   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       m = 1
       For x = 1 To lNumber Step 2
           ReDim Preserve lTempArray(m)
           lTempArray(m) = x
           m = m + 1
       Next
       NextElim = 3: m = 2
       Do
           x = NextElim
           Do While x <= UBound(lTempArray)
               lArrayUBound = UBound(lTempArray)
               If Not x = lArrayUBound Then
                   RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                   ReDim Preserve lTempArray(lArrayUBound - 1)
               Else
                   Exit Function
               End If
               x = x + (NextElim - 1)
           Loop
           m = m + 1
           NextElim = lTempArray(m)
       Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
   End If
End Function

'LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

   Dim lCount As Long, lPos As Long, i As Long
   Dim Arr() As Long

   If Num < 1 Then Exit Function
   If Num Mod 2 = 0 Then Exit Function

   ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))

   For lPos = 1 To Num Step 2
        i = i + 1
        Arr(i) = lPos
   Next


   lCount = 1

   Do While UBound(Arr) > lCount

       lCount = lCount + 1
       lPos = Arr(lCount)

       Do
           If lPos > UBound(Arr) Then Exit Do
           If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
           ReDim Preserve Arr(UBound(Arr) - 1)
           lPos = lPos + Arr(lCount) - 1
       Loop

       If Arr(UBound(Arr)) <> Num Then Exit Function
   Loop

   IsLuckyNumber = True

End Function




Citarmmm me parece que estas tomando mal mi función yo tengo estos resultados

Cierto, disculpame... :-\
Se me olvido poner esto en tu funcion: http://foro.elhacker.net/programacion_visual_basic/reto_comprobar_si_un_numero_dado_es_un_numero_de_la_suerte-t301960.0.html;msg1498223#msg1498223

---

@BlackZer0x
Gracias por realizar la comprobacion ;)

DoEvents¡! :P

Oigan, aquí les dejo mi cuarto intento junto con sus funciones.

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Sub RtlMoveMemory Lib "Kernel32" (ByVal Destination As Any, ByVal Source As Any, ByVal length As Long)
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
   Dim x As Long
   Dim s As String
   Dim t1 As Long
   Dim t2 As Long

'   If App.LogMode = 0 Then End
   Me.AutoRedraw = True

   'Dessa
   Me.Print "Dessa"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLucky(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine

   MsgBox s, vbOKOnly, "Dessa"
   s = ""

   '*PsYkE1*
   Me.Print "PsYkE1"
   t1 = GetTickCount
   For x = 5000 To 7000
       If Check_Lucky_Number3(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   MsgBox s, vbOKOnly, "PsYkE1"
    s = ""
   
   'LeandroA
   Me.Print "LeandroA"
   t1 = GetTickCount
   For x = 5000 To 7000
       If IsLuckyNumber(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   MsgBox s, vbOKOnly, "LeandroA"
   s = ""
   
   'Tokes
   Me.Print "Tokes"
   t1 = GetTickCount
   For x = 5000 To 7000
       If verifnum4(x) Then
           s = s & x & " "
       End If
   Next
   t2 = GetTickCount
   Me.Print t2 - t1 & vbNewLine
   MsgBox s, vbOKOnly, "Tokes"
   s = ""
End Sub

'Dessa
Function IsLucky(lngNum As Long) As Boolean

Dim x As Long, cont As Long, contStep As Long, Indice As Long, numLuck() As Long

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then IsLucky = True: Exit Function
If lngNum = 5 Then Exit Function


For x = 1 To lngNum Step 2
     ReDim Preserve numLuck(contStep)
     numLuck(contStep) = x
     contStep = contStep + 1
Next

contStep = 0: cont = 0: Indice = 1

While numLuck(Indice) <= UBound(numLuck)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
     x = -1
     While x < UBound(numLuck)
         x = x + 1
         If cont = numLuck(Indice) - 1 Then
             cont = 0
         Else
           numLuck(contStep) = numLuck(x)
           cont = cont + 1
           contStep = contStep + 1
         End If
   Wend

   If contStep = numLuck(Indice + 1) Then
       ReDim Preserve numLuck(contStep - 2)
   Else
       ReDim Preserve numLuck(contStep - 1)
   End If
   cont = 0
   contStep = 0
   Indice = Indice + 1
Wend

For x = 0 To UBound(numLuck)
   If numLuck(x) = lngNum Then
     IsLucky = True
     Exit For
   End If
Next

End Function




'-PsYkE1
Public Function Check_Lucky_Number3(ByVal lNumber As Long) As Boolean
   Dim lTempArray()            As Long
   Dim NextElim                As Long
   Dim lArrayUBound            As Long
   Dim m                       As Long
   Dim x                       As Long

   If lNumber = 1 Or lNumber = 3 Then
       GoTo IsLucky
   ElseIf (lNumber > 1) And (lNumber Mod 2 <> 0) Then
       m = 1
       For x = 1 To lNumber Step 2
           ReDim Preserve lTempArray(m)
           lTempArray(m) = x
           m = m + 1
       Next
       NextElim = 3: m = 2
       Do
           x = NextElim
           Do While x <= UBound(lTempArray)
               lArrayUBound = UBound(lTempArray)
               If Not x = lArrayUBound Then
                   RtlMoveMemory VarPtr(lTempArray(x)), VarPtr(lTempArray(x + 1)), (lArrayUBound - x) * 4
                   ReDim Preserve lTempArray(lArrayUBound - 1)
               Else
                   Exit Function
               End If
               x = x + (NextElim - 1)
           Loop
           m = m + 1
           NextElim = lTempArray(m)
       Loop While Not NextElim > lArrayUBound
IsLucky: Check_Lucky_Number3 = True
   End If
End Function

'LeandroA
Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

   Dim lCount As Long, lPos As Long, i As Long
   Dim Arr() As Long

   If Num < 1 Then Exit Function
   If Num Mod 2 = 0 Then Exit Function

   ReDim Preserve Arr(CLng(Num / 2) + (Num Mod 2))

   For lPos = 1 To Num Step 2
        i = i + 1
        Arr(i) = lPos
   Next


   lCount = 1

   Do While UBound(Arr) > lCount

       lCount = lCount + 1
       lPos = Arr(lCount)

       Do
           If lPos > UBound(Arr) Then Exit Do
           If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
           ReDim Preserve Arr(UBound(Arr) - 1)
           lPos = lPos + Arr(lCount) - 1
       Loop

       If Arr(UBound(Arr)) <> Num Then Exit Function
   Loop

   IsLuckyNumber = True

End Function

' Tokes (Cuarto intento)
Private Function verifnum4(ByVal Num As Long) As Boolean
Dim bufA() As Long
Dim indElim As Long
Dim indElim_aux As Long
Dim ordenElim As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long


    If (Num And 1) = 0 Then
        Exit Function
    End If
    If Num < 5 Then
        verifnum4 = True
        Exit Function
    End If
   
    ReDim bufA(0 To Num)
   
    ordenElim = 2
    i = 1
    For i_auxA = 1 To Num Step 2
        bufA(i) = i_auxA
        i = i + 1
    Next i_auxA
    i = i - 1
       
    Do
        indElim = bufA(ordenElim)
        If indElim > i Then
            verifnum4 = True
            Exit Function
        End If
        If indElim = i Then Exit Function
        i_auxA = indElim
        i_auxB = indElim + 1
        Do
            For indElim_aux = indElim - 2 To 0 Step -1
                If i_auxB > i Then Exit Do
                bufA(i_auxA) = bufA(i_auxB)
                i_auxA = i_auxA + 1
                i_auxB = i_auxB + 1
            Next indElim_aux
            If i_auxB = i Then Exit Function
            i_auxB = i_auxB + 1
        Loop
        i = i_auxA - 1
        ordenElim = ordenElim + 1
    Loop
End Function

Mis resultados son:

Dessa --> 12859
PsYkE1 --> 5109
LeandroA --> 3438
Tokes --> 4359

            Saludos.

@ Token, tanto tu code como el mio pierden mucho en el ide, compilado es como se debe tomar los tiempos, excelente tu  codigo (ya lo habia notado) y toma denuevo los tiempos (compilados)

Saludos

.
Hay en la que me pario la de Tokes es mucho mas rapida ya que no usa Redim!¡, tenia planeado realizar una similar sin usar redim pero ya me ganaron  :¬¬ .

Actualize la funcion de Dessa

http://infrangelux.sytes.net/FileX/down.php?InfraDown=/BlackZeroX/Comprovaciones/NumOfLuck/ComprobacionVel%20V2.zip




Dessa --> 1187
PsYkE1 -- > 2015
LeandroA -- > 1313
Cobein -- > 105390
Tokes -- > 204

Se comprobaran Coherencias...

Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5179
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5191
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5299
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5335
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5371
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5419
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5455
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5491
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5503
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5515
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5527
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5551
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5587
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5599
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5671
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5707
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5719
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5755
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5767
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5803
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5827
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5839
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5851
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5911
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5923
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5959
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 5971
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6019
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6031
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6055
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6079
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6115
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6163
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6175
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6211
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6271
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6331
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6355
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6367
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6379
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6415
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6427
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6463
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6475
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6523
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6535
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6559
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6631
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6667
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6679
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6715
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6763
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6787
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6871
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6883
Dessa (Verdadero) ; PsYkE1 (Verdadero) ; LeandroA (Falso) ; Cobein (Verdadero) ; Tokes (Verdadero) ; --> 6931



Dulces Lunas¡.

 :-\ me equivoque de signo / por \

ReDim Preserve Arr(Num \ 2 + (Num Mod 2))


Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Function IsLuckyNumber(ByVal Num As Long) As Boolean

    Dim lCount As Long, lPos As Long, i As Long
    Dim Arr() As Long

    If Num < 1 Then Exit Function
    If Num Mod 2 = 0 Then Exit Function

   ReDim Preserve Arr(Num \ 2 + (Num Mod 2))
   
    For lPos = 1 To Num Step 2
         i = i + 1
         Arr(i) = lPos
    Next


    lCount = 1

    Do While UBound(Arr) > lCount

        lCount = lCount + 1
        lPos = Arr(lCount)

        Do
            If lPos > UBound(Arr) Then Exit Do
            If lPos < UBound(Arr) Then CopyMemory Arr(lPos), Arr(lPos + 1), 4 * (UBound(Arr) - lPos)
            ReDim Preserve Arr(UBound(Arr) - 1)
            lPos = lPos + Arr(lCount) - 1
        Loop

        If Arr(UBound(Arr)) <> Num Then Exit Function
    Loop

    IsLuckyNumber = True

End Function


.
http://infrangelux.sytes.net/FileX/down.php?InfraDown=/BlackZeroX/Comprovaciones/NumOfLuck/ComprobacionVel-3.zip



Dessa --> 1250
PsYkE1 -- > 2078
LeandroA -- > 1453
Cobein -- > 107265
Tokes -- > 204

Se comprobaran Coherencias...



Dulces Lunas!¡.

Tokes nos mato a todos jejej :D

OMFG!!
Buen trabajo Tokes! ;)

DoEvents¡! :P

Gran trabajo Tokes :) Me has animado a sacar una version rapida, rapida, rapida... esta noche voy a esforzarme al maximo >:D :xD

Por cierto, otro buen punto de la funcion es la RAM que ocupa... En eso Cobein va en cabeza ;)

A ver si antes de las 3 tengo una version buena de verdad :)

Saludos

La Funcion de Tokes me parece que se puede hacer mas rapida si en lgar del For Next se sustituye por CopyMemory...

Dulces Lunas!¡.

Cita de: Karcrack en 15 Agosto 2010, 22:38 PM
Gran trabajo Tokes :) Me has animado a sacar una version rapida, rapida, rapida... esta noche voy a esforzarme al maximo >:D :xD

Por cierto, otro buen punto de la funcion es la RAM que ocupa... En eso Cobein va en cabeza ;)

A ver si antes de las 3 tengo una version buena de verdad :)

Saludos

Tengo ganas de ver tu nueva version, a proposito Karcrack, mira a ver si puedes responderme esto por favor:
http://foro.elhacker.net/programacion_visual_basic/reto_comprobar_si_un_numero_dado_es_un_numero_de_la_suerte-t301960.0.html;msg1498532#msg1498532

DoEvents¡! :P

If (x And 1) = 0 Then MsgBox "Funciona"
:P

Karcrack te queria manda un MP pero tenes la casilla llena o si estas en el msn mandame un msg

Saludos.

Buaaah!!! No he conseguido batir al codigo de Tokes, incluso haciendo el algoritmo en ASM... (Resulta que tardo casi lo mismo en cargar el codigo (vTable) que en hacer el algoritmo entero :laugh: :laugh:)

Para mi hay un ganador claro a no ser que se demuestre lo contrario... :P... Asi que, ire pensando otro reto >:D :laugh:

yo queria participar y se me habia ocurrido la idea del redim, pero no me salio el algoritmo y me negaba a fijarme en sus codigos :P y hasta se me ocurrio usar listas enlazadas y doblemente enlazadas, pero mi base del algoritmo fallaba :xD

Muy impresionante lo que hicieron, y si, ya deberian ir cerrando y proclamar un ganador. Yo tengo un reto para mas tarde :P

EDITO:

Solo me falta un if pero no logro resolverlo, me acerqué bastante pero no alcalzó.




Option Explicit
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Form_Load()
  Dim x As Long
  Dim s As String
  Dim t1 As Long
  Dim t2 As Long

  If App.LogMode = 0 Then
  MsgBox "Ejecutar compilado"
  End
  End If
 
  Me.AutoRedraw = True

  'Dessa
  Me.Print "Dessa"
  t1 = GetTickCount
  For x = 5000 To 7000
      If IsLucky(x) Then
          s = s & x & " "
      End If
  Next
  t2 = GetTickCount
  Me.Print t2 - t1 & vbNewLine

  MsgBox s, vbOKOnly, "Dessa"
  s = ""

  'Tokes
  Me.Print "Tokes"
  t1 = GetTickCount
  For x = 5000 To 7000
      If verifnum4(x) Then
          s = s & x & " "
      End If
  Next
  t2 = GetTickCount
  Me.Print t2 - t1 & vbNewLine
  MsgBox s, vbOKOnly, "Tokes"
  s = ""
End Sub

'Dessa

Function IsLucky(lngNum As Long) As Boolean

Dim x As Long
Dim cont As Long
Dim contStep As Long
Dim Indice As Long
Dim numLuck() As Long

If lngNum < 1 Then Exit Function
If lngNum Mod 2 = 0 Then Exit Function
If lngNum = 1 Or lngNum = 3 Then
  IsLucky = True
  Exit Function
End If
If lngNum = 5 Then Exit Function

   ReDim numLuck(lngNum)
   For x = 1 To lngNum Step 2
       numLuck(contStep) = x
       contStep = contStep + 1
   Next
   ReDim Preserve numLuck(contStep - 1)
   
contStep = 0
cont = 0
Indice = 1

While numLuck(Indice) <= UBound(numLuck)
    For x = 0 To UBound(numLuck)
      If cont = numLuck(Indice) - 1 Then
         cont = 0
      Else
          numLuck(contStep) = numLuck(x)
          cont = cont + 1
          contStep = contStep + 1
      End If
    Next
   If contStep = numLuck(Indice + 1) Then
     Exit Function
   Else
     ReDim Preserve numLuck(contStep - 1)
     If numLuck(UBound(numLuck)) <> lngNum Then Exit Function
   End If
   cont = 0
   contStep = 0
   Indice = Indice + 1
Wend
IsLucky = True
 
End Function

' Tokes (Cuarto intento)
Private Function verifnum4(ByVal Num As Long) As Boolean
Dim bufA() As Long
Dim indElim As Long
Dim indElim_aux As Long
Dim ordenElim As Long
Dim i As Long
Dim i_auxA As Long
Dim i_auxB As Long


   If (Num And 1) = 0 Then
       Exit Function
   End If
   If Num < 5 Then
       verifnum4 = True
       Exit Function
   End If
   
   ReDim bufA(0 To Num)
   
   ordenElim = 2
   i = 1
   For i_auxA = 1 To Num Step 2
       bufA(i) = i_auxA
       i = i + 1
   Next i_auxA
   i = i - 1
       
   Do
       indElim = bufA(ordenElim)
       If indElim > i Then
           verifnum4 = True
           Exit Function
       End If
       If indElim = i Then Exit Function
       i_auxA = indElim
       i_auxB = indElim + 1
       Do
           For indElim_aux = indElim - 2 To 0 Step -1
               If i_auxB > i Then Exit Do
               bufA(i_auxA) = bufA(i_auxB)
               i_auxA = i_auxA + 1
               i_auxB = i_auxB + 1
           Next indElim_aux
           If i_auxB = i Then Exit Function
           i_auxB = i_auxB + 1
       Loop
       i = i_auxA - 1
       ordenElim = ordenElim + 1
   Loop
End Function