.


Este código es una mera actualización directa de este otro, se puede decir que es la version 2.0

[source] Números Aleatorio desde X a Y con excepciones.

Vaya solo le falta una opción a mi punto de vista y es meterle una lista de números antes de generar alguno tal cual se le hace en la función solo que ahora seria una propiedad, y podría modificarse en cualquier instante, pero eso se los dejo a ustedes, yo ya hice mi labor.

* El ordenamiento QuickSort se sustituyo por una heuristica mas eficiente.

En un modulo de clase:

cRndNumbersNR.cls

 
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo                    //
' ////////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Declare Function VarPtrA Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub lCopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
 
Private Type stRangos
    lValIni         As Long
    lValEnd         As Long
End Type
 
Private lcvalmax    As Long
Private lcvalmin    As Long
 
Private lvcsplit()  As stRangos
Private lacexcep()  As Long
 
Private bChange     As Long
 
Private Sub Swapnumbers(ByRef lvalone As Long, ByRef lvaltwo As Long)
'   //  Intercambia el contenido de las variables.
Dim lvaltmp         As Long
    lvaltmp = lvalone
    lvalone = lvaltwo
    lvaltwo = lvaltmp
End Sub
 
Private Function Fixnumbers(ByRef lvalmin As Long, lvalmax As Long) As Boolean
'   //  Corrige los valores dados.
    If lvalmax < lvalmin Then
        Call Swapnumbers(lvalmin, lvalmax)
        Fixnumbers = True
    End If
End Function
 
Private Function NumRandom(lvalmin As Long, lvalmax As Long) As Long
'   //  Genera un Numero aleatorio de acuerdo a un rango dado.
    Call Fixnumbers(lvalmin, lvalmax)
    Call Randomize
    NumRandom = (lvalmin - lvalmax) * Rnd + lvalmax
End Function
 
Public Sub Reset()
'   //  Reinicia y permite nuevamente generar los números aleatorios desde el principio, si no aplica este al generar todos los numeros, entonces no generara mas números y devolverá únicamente 0..
    Erase lvcsplit()
    Erase lacexcep()
    ReDim lvcsplit(0 To 0)
    lvcsplit(0).lValIni = lcvalmin
    lvcsplit(0).lValEnd = lcvalmax
    bChange = False
End Sub
 
Public Property Get GetMore() As Boolean
'   //  Hay mas ocurrencias? cuando ya no hay se elimina el array de ocurrencias.
    GetMore = Itsarrayini(VarPtrA(lvcsplit)) Or bChange = True
End Property
 
Private Function Itsarrayini(ByVal lpszv As Long, Optional llen As Long = 4) As Boolean
'   //  Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
Dim lpsz                    As Long
    If lpszv <> 0 And llen > 0 Then
        Call lCopyMemory(ByVal VarPtr(lpsz), ByVal lpszv, llen)
        Itsarrayini = Not lpsz = 0
    End If
End Function
 
Private Sub SeparateRange(ByVal lDivVal As Long, ByVal lindex As Long, ByRef vArray() As stRangos)
'   //  Es un proceso para aplicar el dicho "Divide y Venceras", esto aumenta mucho la velocidad para no repetir numeros dentro de un rango dado y generados de manera aleatoria.
'   //  Repeti un poco de codigo lo siento xP...
Dim lu          As Long
Dim lpsz        As Long
 
    If (vArray(lindex).lValIni <= lDivVal And lDivVal <= vArray(lindex).lValEnd) Then
        lu = UBound(vArray)
        lpsz = VarPtr(vArray(lindex))
        If (vArray(lindex).lValIni = lDivVal) Then
            vArray(lindex).lValIni = vArray(lindex).lValIni + 1
            If (vArray(lindex).lValIni > vArray(lindex).lValEnd) Then
                If (lu > 0) Then
                    lCopyMemory lpsz, lpsz + &H8, ((lu - lindex) * &H8)
                    lu = lu - 1
                    ReDim Preserve vArray(0 To lu)
                Else
                    Erase vArray()
                End If
            End If
        ElseIf (vArray(lindex).lValEnd = lDivVal) Then
            vArray(lindex).lValEnd = vArray(lindex).lValEnd - 1
            If (vArray(lindex).lValIni > vArray(lindex).lValEnd) Then
                If (lu > 0) Then
                    lCopyMemory lpsz, lpsz + &H8, ((lu - lindex) * &H8)
                    lu = lu - 1
                    ReDim Preserve vArray(0 To lu)
                Else
                    Erase vArray()
                End If
            End If
        Else
            lu = lu + 1
            ReDim Preserve vArray(0 To lu)
            lpsz = VarPtr(vArray(lindex))
            lCopyMemory lpsz + &H10, (lpsz + &H8), (((lu - 1) - lindex) * &H8)
            vArray(lindex + 1).lValEnd = vArray(lindex).lValEnd
            vArray(lindex + 1).lValIni = (lDivVal + 1)
            vArray(lindex).lValEnd = (lDivVal - 1)
 
        End If
    End If
 
End Sub
 
Public Property Get GetNumRandom() As Long
'   //  Genera un numero aleatorio sin repetir de acuerdo a un rango de valores dados.
Dim lindex          As Long
Dim lu              As Long
Dim lret            As Long
    If (bChange = True) Then
        Call Fixnumbers(lcvalmin, lcvalmax)
        Call Reset
    End If
    If (GetMore = True) Then
        lindex = NumRandom(0, UBound(lvcsplit))
        lret = NumRandom(lvcsplit(lindex).lValIni, lvcsplit(lindex).lValEnd)
        SeparateRange lret, lindex, lvcsplit
        If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
            lu = UBound(lacexcep) + 1
        Else
            lu = 0
        End If
        ReDim Preserve lacexcep(0 To lu)
        lacexcep(lu) = lret
        GetNumRandom = lret
    End If
End Property
 
Public Property Let minval(ByVal ldata As Long)
'   //  Establece el limite inferior de los numeros a generar de manera aleatoria sin repetir.
    lcvalmin = ldata
    bChange = True
End Property
 
Public Property Get minval() As Long
'   //  Obtiene el limite inferior de los numeros a generar de manera aleatoria sin repetir.
    minval = lcvalmin
End Property
 
Public Property Let maxval(ByVal ldata As Long)
'   //  Establece el limite superior de los numeros a generar de manera aleatoria sin repetir.
    lcvalmax = ldata
    bChange = True
End Property
 
Public Property Get maxval() As Long
'   //  Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
    maxval = lcvalmax
End Property
 
Public Property Get GetNumbers() As Long()
'   //  Devueve una coleccion de los numeros generados.
    GetNumbers() = lacexcep()
End Property
 
Public Function RegenerateThis(ByVal lVal As Long) As Boolean
Dim ii              As Long
Dim lub             As Long
    If (lcvalmin <= lVal) And (lcvalmax >= lVal) Then
        If (breglist = True) Then
            If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
                For ii = 0 To UBound(lacexcep)
                    If (lacexcep(ii) = lVal) Then
                        RemoveInArrayLong ii, lacexcep()
                        Exit For
                    End If
                Next ii
            End If
        End If
        If (Itsarrayini(VarPtrA(lvcsplit)) = True) Then
            lub = UBound(lvcsplit)
            For ii = 0 To (lub - 1)
                If (lvcsplit(ii).lValEnd > lVal) And (lvcsplit(ii + 1).lValIni < lVal) Then
                    If ((lvcsplit(ii).lValEnd + 1) = lVal) Then
                        lvcsplit(ii).lValEnd = lVal
                    ElseIf ((lvcsplit(ii + 1).lValIni) = lVal) Then
                        lvcsplit(ii + 1).lValIni = lVal
                    End If
                    Select Case (lvcsplit(ii).lValEnd = lvcsplit(ii + 1).lValIni)
                        Case 0, 1
                            lub = (lub - 1)
                            lvcsplit(ii).lValEnd = lvcsplit(ii + 1).lValEnd
                            ReDim Preserve lvcsplit(0 To lub)
                        Case Else
                            If Not ((lvcsplit(ii).lValEnd + 1) = lvcsplit(ii + 1).lValIni) Then
                                lub = (lub + 1)
                                ReDim Preserve lvcsplit(0 To lub)
                                SwapBlockMemoryInCicle VarPtr(lvcsplit(ii)), (VarPtr(lvcsplit(lub)) + LenB(lvcsplit(0))), LenB(lvcsplit(0))
                                lvcsplit(ii + 1).lValIni = lVal
                                lvcsplit(ii + 1).lValEnd = lVal
                            End If
                    End Select
                    RegenerateThis = True
                Else
                    Exit For
                End If
            Next ii
        Else
            ReDim lvcsplit(0 To 0)
            lvcsplit(0).lValIni = lVal
            lvcsplit(0).lValEnd = lVal
        End If
    End If
End Function
 
Private Sub Class_Initialize()
'   //  Constructor de la clase, no tengo por que hacer lo siguiente pero como me estoy adaptando a un standart lo hare.
    bChange = False
End Sub
 
 

uso simple:

 
Option Explicit
 
Private Sub Form_Load()
Dim cls     As cRndNumber
Dim lc      As Long
    Set cls = New cRndNumber
    With cls
    '   //  Este simple codigo probara la velocidad, que de hecho ya es rapido a consideracion de otros que conozco.
        .minval = 0
        .maxval = 99999
        Do While (.GetMore = True)
            DoEvents
            lc = .GetNumRandom
        Loop
        MsgBox "Se recorrieron todos los numeros sin repetir alguno xD"
    '   //  Si se cambian los valores menor y mayor entonces es como si se le aplicara call .Reset
    '   //  Este codigo hara un test de repeticion
        .minval = 0
        .maxval = 99
        Do While (.GetMore = True)
            DoEvents
            Debug.Print .GetNumRandom
        Loop
 
        MsgBox "Se recorrieron todos los numeros sin repetir alguno xD"
    End With
End Sub
 
 

Temibles Lunas!¡.

PISTA:
Debes buscar el indice del array donde se encuentre el valor a excluir y pasarlo por la función:

Private Sub SeparateRange(ByVal lDivVal As Long, ByVal lindex As Long, ByRef vArray() As stRangos)

Reformando la funcion ItsInArray se puede hacer, no me gustaría ver un For Next que recorra todos elementos del array ya que es algo muy feo y no entra en la relación Tiempo-Procesador ya que alentaria mucho el proceso.

Dulces Lunas!¡.

Quizás puedas ahorrarte los RedimPreserve() que gastan mucho tiempo y redimensionarlo cada 1024 elementos.
¿Y para devolverlos en la propiedad GetNumbers() sería más rápido copiando el array CopyMemory()?

DoEvents!

Algo así, por ejemplo:

'...
 
Public Property Get GetNumRandom() As Long
'   //  Genera un numero aleatorio sin repetir de acuerdo a un rango de valores dados.
Dim lindex          As Long
Dim lu              As Long
Dim lret            As Long
    If (bChange = True) Then
        Call Fixnumbers(lcvalmin, lcvalmax)
        Call Reset
    End If
    If (GetMore = True) Then
        lindex = NumRandom(0, UBound(lvcsplit))
        lret = NumRandom(lvcsplit(lindex).lValIni, lvcsplit(lindex).lValEnd)
        SeparateRange lret, lindex, lvcsplit
        If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
            lu = UBound(lacexcep) + 1
            If (lu Mod &H3FF) = 0 Then '# si la matriz tiene 1024 elementos (lo puedes hacer con And también)
                ReDim Preserve lacexcep(0 to (lu + &H400)) '# le añadimos 1024 más...
            End If
        Else
            lu = 0
            Redim lacexcep(0)
        End If
        lacexcep(lu) = lret
        GetNumRandom = lret
    End If
End Property
 
'...
 
Private Sub Class_Initialize()
'   //  Constructor de la clase, no tengo por que hacer lo siguiente pero como me estoy adaptando a un standart lo hare.
    ReDim lacexcep(&H3FF) '# iniciamos la matriz con 1024
    bChange = False
End Sub

---

En cuanto a lo de copiar la matriz...
Hice este test y... ¡sorpresa!
Gana RtlMoveMemory()

Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)
 
Private Sub Form_Load()
Const Max& = 999990
Dim q&, a&(Max), b&(), t As New CTiming
    Me.AutoRedraw = True
 
    ReDim b&(Max)
 
    For q = 0 To Max
        a(q) = q
    Next q
 
    t.Reset
    RtlMoveMemory VarPtr(b(0)), VarPtr(a(0)), (Max + Max + Max + Max + 4) '// Procuro evitar multiplicaciones...
    Me.Print "RtlMoveMemory", t.sElapsed
 
    ReDim b&(Max)
 
    t.Reset
    b = a
    Me.Print "Igualación", , t.sElapsed
 
   '// Con Set me tiraba error... xP
End Sub

Resultado:


DoEvents!

Sería genial que la técnica esa la emplearas también con vArray(), puesto que las estructuras pesan 8 Bytes.
Es cierto lo que dices, en el test no conté con eso...
Está bien como está.

Pd1:

Public Property Get maxval() As Long
'   //  Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
    minval = lcvalmax '// Sería maxval
End Property

Pd2: Estaría genial que pusieras más ejemplos usando todas las propiedades para que a la gente le quedara más claro.

Pd3:
Ook, comienza la cuanta atrás...

DoEvents!