[RETO] Comprobar si un numero dado es un numero de la suerte

Dessa · 14 Agosto 2010, 22:28 PM

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

Tokes · 15 Agosto 2010, 00:21 AM

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):

Código [Seleccionar]

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

Angeldj27 · 15 Agosto 2010, 01:08 AM

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¡!

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

Psyke1 · 15 Agosto 2010, 01:36 AM

Mira, te pongo un ejemplo:

Código (vb) [Seleccionar]


  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...

Ahora pruebalo asi:

Código (vb) [Seleccionar]

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

DoEvents¡!

LeandroA · 15 Agosto 2010, 05:12 AM

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

Dessa
2125

PsYkE1
2000

LeandroA
1172

pongo las tres funciones

Código (Vb) [Seleccionar]



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

BlackZeroX · 15 Agosto 2010, 07:28 AM

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!¡.

Código [Seleccionar]



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!¡.

BlackZeroX · 15 Agosto 2010, 07:33 AM

Aqui el proyecto de comprobacion!¡.

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

Código [Seleccionar]




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!¡.

Dessa · 15 Agosto 2010, 07:48 AM

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

Código [Seleccionar]



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

Psyke1 · 15 Agosto 2010, 11:00 AM

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¡!

Tokes · 15 Agosto 2010, 18:27 PM

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

Código [Seleccionar]

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.