[SRC] LoadRndNumericArray

Bueno, cómo ahora está de moda los numeros aleatorios encontré un hueco entre mis estudios y hice esto.
Soporta divrersos tipos de arrays...(Long, Byte, Integer...).
Uso la funcion de BlackZer0x :
http://goo.gl/RG4Bx
Tuve que cambiar un par de cosas nada más para adaptarlo.

Función:

Código

Option Explicit
'======================================================================
' º Function  : LoadRndNumericArray
' º Author    : Psyke1
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 27/05/2011
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Dedicated : BlackZer0x
' º Requirements : http://goo.gl/vgbtQ || http://goo.gl/BAPXx
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://www.frogcheat.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)
 
Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
    If IsArray(varOutPutArr) Then
        If lngMin < lngMax Then
            lngTotal = lngMax - lngMin
            C = 0
 
            If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
                Start_QuickSort varExceptionArr '// With little mod.
 
                lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
                ReDim lngFinalArr&(0 To lngTotal)
 
                '// Fix repetitions and numbers out of range.
                For Q = lngMin To lngMax
                    If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                        lngFinalArr(C) = Q
                        C = C + 1
                    End If
                Next Q
            Else
                ReDim lngFinalArr&(0 To lngTotal)
 
                For Q = lngMin To lngMax
                    lngFinalArr(C) = Q
                    C = C + 1
                Next Q
            End If
 
            ReDim varOutPutArr(0 To lngTotal)
            Randomize Timer
 
            For Q = 0 To lngTotal
                lngRndIndex = Rnd * lngTotal
                varOutPutArr(Q) = lngFinalArr(lngRndIndex)
 
                RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
                lngTotal = lngTotal - 1
            Next Q
 
            LoadRndNumericArray = True
        End If
    End If
End Function

Ejemplo:

Código

Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)
 
Enum EnuListOrder
    AcendetOrder = 0
    DecendentOrder = 1
End Enum
 
Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
    If IsArray(varOutPutArr) Then
        If lngMin < lngMax Then
            lngTotal = lngMax - lngMin
            C = 0
 
            If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
                Start_QuickSort varExceptionArr
 
                lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
                ReDim lngFinalArr&(0 To lngTotal)
 
                '// Fix repetitions and numbers out of range.
                For Q = lngMin To lngMax
                    If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                        lngFinalArr(C) = Q
                        C = C + 1
                    End If
                Next Q
            Else
                ReDim lngFinalArr&(0 To lngTotal)
 
                For Q = lngMin To lngMax
                    lngFinalArr(C) = Q
                    C = C + 1
                Next Q
            End If
 
            ReDim varOutPutArr(0 To lngTotal)
            Randomize Timer
 
            For Q = 0 To lngTotal
                lngRndIndex = Rnd * lngTotal
                varOutPutArr(Q) = lngFinalArr(lngRndIndex)
 
                RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
                lngTotal = lngTotal - 1
            Next Q
 
            LoadRndNumericArray = True
        End If
    End If
End Function
 
'   /////////////////////////////////////////////////////////////
'   // Autor Algoritmo: C.A.R. Hoare en 1960                   //
'   // 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                 //
'   /////////////////////////////////////////////////////////////
 
Private Sub AuxOrden(ByRef mArray, i As Long, j As Long, il As Long, jl As Long)
Dim C                                       As String
Dim c2                                      As Long
    C = mArray(j)
    mArray(j) = mArray(i)
    mArray(i) = C
    c2 = il
    il = -jl
    jl = -c2
End Sub
 
Private Sub PreSort(ByRef mArray, lb As Long, ub As Long, k As Long, Optional 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(mArray(i)) And IsNumeric(mArray(j)) Then
                If Val(mArray(i)) > Val(mArray(j)) Then
                    Call AuxOrden(mArray(), i, j, il, jl)
                End If
            Else
                If mArray(i) > mArray(j) Then
                    Call AuxOrden(mArray(), i, j, il, jl)
                End If
            End If
        Else
            If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
                If Val(mArray(i)) < Val(mArray(j)) Then
                    Call AuxOrden(mArray(), i, j, il, jl)
                End If
            Else
                If mArray(i) < mArray(j) Then
                    Call AuxOrden(mArray(), i, j, il, jl)
                End If
            End If
        End If
        i = i + il
        j = j + jl
    Wend
    k = i
End Sub
 
Private Sub QSort(ByRef mArray, lb As Long, ub As Long, _
                Optional Order As EnuListOrder = DecendentOrder)
Dim k                                   As Long
    If lb < ub Then
        PreSort mArray, lb, ub, k, Order
        Call QSort(mArray, lb, k - 1, Order)
        Call QSort(mArray, k + 1, ub, Order)
    End If
End Sub
 
Public Sub Start_QuickSort(ByRef mArray, Optional Order As EnuListOrder = DecendentOrder)
    QSort mArray, LBound(mArray), UBound(mArray), Order
End Sub
 
'// by Psyke1
Public Static Function IsInArray&(varArr, _
                                  varValue, _
                                  Optional lngStart&, _
                                  Optional lngEnd&, _
                                  Optional bolFindFirst As Boolean, _
                                  Optional bolIsSorted As Boolean)
Dim lngLB&, lngUB&, Q&, C&
    If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then
        lngLB = LBound(varArr)
        lngUB = UBound(varArr)
 
        If Not IsMissing(lngStart) Then
           If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
        End If
        If Not IsMissing(lngEnd) Then
           If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
        End If
 
        If bolIsSorted Then
            If varArr(lngLB) = varValue Then
                IsInArray = lngLB
                Exit Function
            ElseIf varArr(lngUB) = varValue Then
                If bolFindFirst Then
                    Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB)
                        lngUB = lngUB - 1
                    Loop
                End If
 
                IsInArray = lngUB
                Exit Function
            End If
 
            If lngUB - lngLB < 2 Then GoTo NotFound
            If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound
 
            C = 0
            Do
                Q = (lngUB + lngLB) \ 2
                If C = Q Then GoTo NotFound
 
                If varArr(Q) > varValue Then
                    lngUB = Q
                ElseIf varArr(Q) < varValue Then
                    lngLB = Q
                    C = lngLB
                Else
                    If bolFindFirst Then
                        Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB)
                            Q = Q - 1
                        Loop
                    End If
 
                    IsInArray = Q
                    Exit Function
                End If
            Loop
        Else
            For Q = lngLB To lngUB
                If varArr(Q) = varValue Then
                    IsInArray = Q
                    Exit Function
                End If
            Next Q
 
            GoTo NotFound
        End If
    End If
Exit Function
 
NotFound:
    IsInArray = -1
End Function
 
Private Sub Form_Load()
Dim varItem, lngOut&(), intEx%(0 To 3)
 
    intEx(0) = -2
    intEx(1) = 1
    intEx(2) = 5
    intEx(3) = 8
 
    Debug.Print String$(40, "="), Time$
 
    If LoadRndNumericArray(-5, 10, lngOut, intEx) Then
        For Each varItem In lngOut
            Debug.Print varItem
        Next varItem
    End If
End Sub

Resultado:

Código:

========================================  20:10:55
 4 
-4 
 7 
 3 
 9 
-1 
-5 
 0 
 10 
 2 
 6 
-3

Voy a seguir estudiando para la selectividad...

Bye

DoEvents!