¿Todavía sigues usando Collections?
¡¡Ahora lo que se lleva es cCollectionEx.cls!!

---

Propiedades:

Add

Add(ByRef Item As Variant, Optional ByVal Index As Long)

¿A qué has adivinado que hace? pero incluyo la opcion de insertarlo en un Index especifico.

Contains

Contains(ByRef Item As Variant, Optional ByVal StartIndex As Long = 1)

Sirve para comprbar si un Item ya esta contenido dentro de nuestra cCollectionEx, tambien puedes empezar a buscarlo desde un Index especifico.

Count

Count()

Devuelve la cantidad de Items almacenados.

Item

Item(ByVal Index As Long)

Indica el contenido de in Item en concreto a partir de su Index.

DeleteItem

DeleteItem(ByVal Index As Long)

Borra un Item determinado a partir de el Index ingresado.

SwapItem

SwapItem(ByVal ActualIndex As Long, ByVal DestinationIndex As Long)

Intercambia dos Items.

Sorted

Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder) ' by BlackZeroX
 

Ordena la cCollectionEx alfanumericamente y ademas puedes indicar el orden [descendente/ascendente].

Reverse

Reverse()

Invierte la posicion del contenido de cCollectionEx.

Clear

Clear()

Borra el contenido de cCollectionEx.

---

Aquí la clase:

Option Explicit
Option Base 1
'=====================================================================
' º Class         : cCollectionEx.cls
' º Author        : Psyke1
' º Mail          : vbpsyke1@mixmail.com
' º Date          : 17/8/10
' º Last modified : 01/06/12
' º Purpose       : Replace and improve the vb6 Collection Object
' º Greets        : BlackZer0x & xkiz
' º Sorted by BlackZer0x :
'           http://bit.ly/M5zCKw
' º Recommended Websites :
'           http://foro.h-sec.org/
'           http://www.frogcheat.com.ar/
'           http://infrangelux.sytes.net/
'=====================================================================
Private Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByVal pDest As Long, ByVal pSrc As Long, ByVal lBytes As Long)
 
Public Enum EnuListOrder
    AcendetOrder = 0
    DecendentOrder = 1
End Enum
 
Private vColl()                             As Variant
Private lCount                              As Long
Private lLimit                              As Long
Private ReverseMode                         As Boolean
 
 
'// Inizialice the matrix.
Private Sub Class_Initialize()
    lLimit = &H400
    ReDim vColl(lLimit)
End Sub
 
'// It returns the number of items contained in the matrix.
Public Property Get Count() As Long
    Count = lCount
End Property
 
'// It returns an specific item form there index.
Public Property Get Item(ByVal Index As Long) As Variant
    If ReverseMode Then FixIndex Index
    Item = vColl(Index)
End Property
 
'// It returns the index of an item if exists in the matrix.
Public Function Contains(ByRef Item As Variant, Optional ByVal StartIndex As Long = 1) As Long
Dim Q                                       As Long
 
    If (StartIndex < lCount) And (StartIndex > 0) Then
        For Q = StartIndex To lCount
            If vColl(Q) = Item Then
                If ReverseMode Then
                    Contains = lCount + 1 - Q
                Else
                    Contains = Q
                End If
 
                Exit Function
            End If
        Next
    End If
End Function
 
'// Add a new item to the cCollection, if you specify the index so you can add in a particular position.
Public Function Add(ByRef Item As Variant, Optional ByVal Index As Long) As Long
    If IsObject(Item) = False Then
        If ReverseMode Then FixIndex Index
 
        lCount = lCount + 1
 
        If lCount > lLimit Then
           lLimit = lLimit + lLimit
           ReDim Preserve vColl(lLimit)
        End If
 
        If Index > 0 And Index <= lCount Then
            RtlMoveMemory VarPtr(vColl(Index + 1)), VarPtr(vColl(Index)), (lCount - Index) * 16&
            Add = Index
        Else
            Add = lCount
        End If
 
        vColl(Add) = Item
    End If
End Function
 
'// Delete an specific item from its index.
Public Function DeleteItem(ByVal Index As Long) As Long
    If (Index > 0) And (Index <= lCount) Then
        If ReverseMode Then FixIndex Index
 
        If (Index < lCount) Then
            RtlMoveMemory VarPtr(vColl(Index)), VarPtr(vColl(Index + 1)), (lCount - Index) * 16&
        End If
 
        If (lCount - 1) > 0 Then
            lCount = lCount - 1
        Else
            Clear
        End If
 
        DeleteItem = Index
    End If
End Function
 
'// Swaps the contents of two items entering its index.
Public Function SwapItem(ByVal FirstIndex As Long, ByVal DestIndex As Long) As Long
Dim vSwap                                   As Variant
 
    If (FirstIndex <= lCount And FirstIndex > 0) And (DestIndex <= lCount And DestIndex > 0) And (FirstIndex <> DestIndex) Then
        If ReverseMode Then
            FixIndex FirstIndex
            FixIndex DestinationIndex
        End If
 
        vSwap = vColl(FirstIndex)
        vColl(FirstIndex) = vColl(DestIndex)
        vColl(DestIndex) = vSwap
        SwapItem = DestIndex
    End If
End Function
 
'// Reverse all Items.
Public Sub Reverse()
    ReverseMode = Not ReverseMode
End Sub
 
'// Deletes all items.
Public Sub Clear()
    Erase vColl
    lCount = 0&
End Sub
 
'// To simplify code, it's to reverse the index.
Private Sub FixIndex(ByRef lIndex As Long)
    lIndex = lCount + 1 - lIndex
End Sub
 
'// Sort items alphanumerically and you can specify the order too [desdendent or ascendent].
Public Sub Sorted(Optional ByVal Order As EnuListOrder = DecendentOrder)
    If (Not (vColl)) = -1 Then Exit Sub
    Call QSort(1, lCount, Order)
End Sub
 
Private Sub QSort(ByVal lb As Long, ByVal ub As Long, Optional ByVal Order As EnuListOrder = DecendentOrder)
Dim k                                As Long
    If lb < ub Then
        Call PreSort(lb, ub, k, Order)
        Call QSort(lb, k - 1, Order)
        Call QSort(k + 1, ub, Order)
    End If
End Sub
 
Private Sub PreSort(ByVal lb As Long, ByVal ub As Long, ByRef k As Long, Optional ByVal Order As EnuListOrder = DecendentOrder)
Dim i                               As Long
Dim j                               As Long
Dim il                              As Long
Dim jl                              As Long
    il = 0: jl = -1
    i = lb: j = ub
    While i < j
        If Order = DecendentOrder Then
            If IsNumeric(vColl(i)) And IsNumeric(vColl(j)) Then
                If Val(vColl(i)) > Val(vColl(j)) Then Call AuxOrden(i, j, il, jl)
            Else
                If vColl(i) > vColl(j) Then Call AuxOrden(i, j, il, jl)
            End If
        Else
            If IsNumeric(vColl(i)) And IsNumeric(vColl(j)) Then
                If Val(vColl(i)) < Val(vColl(j)) Then Call AuxOrden(i, j, il, jl)
            Else
                If vColl(i) < vColl(j) Then Call AuxOrden(i, j, il, jl)
            End If
        End If
        i = i + il
        j = j + jl
    Wend
    k = i
End Sub
 
Private Sub AuxOrden(ByVal i As Long, ByVal j As Long, ByVal il As Long, ByVal jl As Long)
Dim c                               As String
Dim c2                              As Long
    c = vColl(j)
    vColl(j) = vColl(i)
    vColl(i) = c
    c2 = il
    il = -jl
    jl = -c2
End Sub
 

---

¿No crees que sea más rapido?  

Pon esto en un form, añade la clase y compílalo:

Option Explicit
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
' Con Collection
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
 
' Con cCollectionEx
Public Function Check_Lucky_Number2(ByVal lNumber As Long) As Boolean
    Dim cTemp                   As New cCollectionEx
    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
                    Call .DeleteItem(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_Number2 = True
    End If
End Function
 
Private Sub Form_Load()
    Dim T1          As Long
    Dim T2          As Long
    Dim x           As Long
    Dim sResult     As String
 
    If App.LogMode = 0 Then
        MsgBox "Prueba con proyecto compilado¡!", vbCritical
        End
    End If
 
    T1 = GetTickCount
    For x = 5000 To 7000
        If Check_Lucky_Number(x) Then
            sResult = sResult & x & " "
        End If
    Next
    T2 = GetTickCount
    MsgBox "With Collection -> " & (T2 - T1)
    MsgBox sResult
 
    '*************************************************************************
    sResult = ""
    '*************************************************************************
 
    T1 = GetTickCount
    For x = 5000 To 7000
        If Check_Lucky_Number2(x) Then
            sResult = sResult & x & " "
        End If
    Next
    T2 = GetTickCount
    MsgBox "With cCollectionEx -> " & (T2 - T1)
 
    MsgBox sResult
End Sub

La diferencia suele oscilar entre los 2500/3000 ms  
EDIT: He mejorado la clase, ahora será bastante mayor.

DoEvents¡!

Guau! 
Muchas gracias Debci! 

DoEvents¡!

Exacto, pero una cosa:
Porque tengo que comprobar que no sea objeto en SwapItem, si a la hora de añadir un Item no dejo que sea objeto?¿  

EDITO:
Soy tonto  entendi lo contrario, estoy trabajando en ello... 

DoEvents¡!

Lo vi por encima y se ve muy bien! Lo mejor es que mejoras el performance. Si tienes tiempo y si es posible, agregale algo como AddRange, para agregar otra collection a una ya existente. También un Reverse. xD no se me ocurre más nada

Saludos!

Bueno, he añadido la funcion Reverse!
Gracias por la sugerencia [D4N93R]!

@BlackZer0x
La clase no acepta objetos, pero ¿porque dices que lo compruebe en SwapItem o en Contains si ya se que no los va ha haber, puesto que al añadirlos prescindo de los mismos?  

DoEvents¡!