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
