Foro de elhacker.net

 
Option Explicit
 
Private Type stRangos
    lValIni         As Long
    lValEnd         As Long
End Type
 
Public Sub swapNumbers(ByRef lValOne As Long, ByRef lValTwo As Long)
Dim lValTmp         As Long
    lValTmp = lValOne
    lValOne = lValTwo
    lValTwo = lValTmp
End Sub
 
Public Function FixNumbers(ByRef lValMin As Long, lValMax As Long) As Boolean
    If lValMax < lValMin Then
        Call swapNumbers(lValMin, lValMax)
        FixNumbers = True
    End If
End Function
 
Public Function NumeroAleatorio(lValMin As Long, lValMax As Long) As Long
    Call FixNumbers(lValMin, lValMax)
    Call Randomize
    NumeroAleatorio = (lValMin - lValMax) * Rnd + lValMax
End Function
 
Public Function NumeroAleatorioEx(ByVal lValIni As Long, ByVal lValEnd As Long, ParamArray aNoRepet() As Variant) As Long
'   //  Debera pasarse el parametro {aNoRepet} ordenado de menor a mayor ( indice lbound siendo el valor menor y ubound el valor mayor ).
'   //  La funcion Si no puede generar un numero aleatorio retornara {lValIni-1}
On Error GoTo GetNumber
Dim avArray()       As Variant
Dim lUB             As Long
Dim lNextVal        As Long
Dim li              As Long, lIndex         As Long
Dim tRangos()       As stRangos
 
    If (Not IsMissing(aNoRepet)) Then
        If (IsArray(aNoRepet(0))) Then
            avArray = aNoRepet(0)
        Else
            avArray = aNoRepet
        End If
 
        lUB = UBound(avArray)
        Call Start_QuickSort(avArray, AcendetOrder)     '   //  http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=14:artquicksortybublesort&catid=2:catprocmanager&Itemid=8
 
        ReDim tRangos(0 To (lUB + 1))                   '   //  Cache de memoria...
        With tRangos(0)
            .lValIni = lValIni
            .lValEnd = lValEnd
        End With
        lNextVal = lValIni
        lIndex = 0
 
        For li = 0 To lUB
            If (avArray(li) <= lValEnd And _
                avArray(li) > lValIni And _
                lNextVal <> avArray(li)) Then
                If (lNextVal > lValIni) Then
                    lIndex = lIndex + 1
                    With tRangos(lIndex)
                        .lValIni = lNextVal
                        .lValEnd = avArray(li) - 1
                    End With
                    lNextVal = (avArray(li) + 1)
 
                ElseIf (lNextVal = lValIni) Then
                    tRangos(lIndex).lValEnd = avArray(li) - 1
                    lNextVal = (avArray(li) + 1)
 
                End If
            ElseIf (avArray(li) = tRangos(0).lValIni) Then
                lIndex = lIndex - 1
                lNextVal = tRangos(0).lValIni + 1
            Else
                lNextVal = lNextVal + 1
            End If
        Next
 
        If (lIndex > -1) Then
            If ((tRangos(lIndex).lValEnd + 1) <= lValEnd And lNextVal <= lValEnd) Then
                lIndex = lIndex + 1
                ReDim Preserve tRangos(0 To lIndex)
                With tRangos(lIndex)
                    .lValIni = avArray(lUB) + 1
                    .lValEnd = lValEnd
                End With
            Else
                ReDim Preserve tRangos(0 To lIndex)
            End If
 
        ElseIf (lNextVal > lValEnd) Then
            NumeroAleatorioEx = lValIni - 1
            Exit Function
 
        Else
            lIndex = 0
            tRangos(lIndex).lValIni = lNextVal
 
        End If
 
        li = NumeroAleatorio(0, lIndex)
        NumeroAleatorioEx = NumeroAleatorio(tRangos(li).lValIni, tRangos(li).lValEnd)
        Exit Function
 
    End If
GetNumber:
    NumeroAleatorioEx = NumeroAleatorio(lValIni, lValEnd)
End Function
 
Private Sub Form_Load()
Dim ii              As Integer
Dim lres            As Long
Dim vArray()        As Variant
 
Const lValIni       As Long = 5
Const lValEnd       As Long = 10
 
    lres = NumeroAleatorioEx(lValIni, lValEnd)
    ReDim vArray(0 To 0)
    vArray(ii) = lres
    Debug.Print lres
    For ii = 1 To 11
        lres = NumeroAleatorioEx(lValIni, lValEnd, vArray)
        ReDim Preserve vArray(0 To ii)
        vArray(ii) = lres
        If (lres = (lValIni - 1)) Then
            Debug.Print "Ya no se pueden crear mas numeros aleatorios, las esecciones llenan todas las opciones."
        Else
            Debug.Print lres
        End If
    Next ii
End Sub
 
 

sub CargarMatrizAleatoria(Min as long, Max as long, Excepciones() as long, lOutputArr() as long)