X Unique Randomize Numbers

user_18129201 0
Viewed 70

i need a little bit help. Is it possible to fill a list with random numbers and to check this list before each loop to see if the number already exists?

I think im on the wrong way with my VBA.

Sub Zufallszahlen()

Dim Rng As Range

Max = 6
Min = 1
Anzahl = 4
counter = 0
innercounter = 0
SZeile = 2
AWert = "X"

Range("C:C").Clear

Do
    counter = counter + 1
    ZZahl = Int((Max * Rnd) + Min)
    innercounter = 0
    
    Do
        innercounter = innercounter + 1
            If Cells(innercounter, 2) = ZZahl Then
            ZZahl = Int((Max * Rnd) + Min)
        
        Else
    Loop Until innercounter = Anzahl
        
    ' Cells(counter, 1).Value = counter
    Cells(counter, 2).Value = ZZahl
    Cells(ZZahl, 3).Value = AWert
    
Loop Until counter = Anzahl

Range("B:B").Clear
End Sub
vba excel
3 Answers

Use an array to check if random number has already been chosen. Repeat until a vacant array position is found.

Option Explicit

Sub Zufallszahlen()
    
    Const MaxN = 6
    Const MinN = 1
    Const Anzahl = 4
    Const Awert = "X"
    
    Dim ar, n As Long, r As Long, i As Long
    n = MaxN - MinN + 1
    If n < Anzahl Then
        MsgBox "Min to Max range must be >= " & Anzahl
        Exit Sub
    End If
    
    ' values in column B
    Dim arB, total As Single, try As Long
    arB = Range("B" & MinN).Resize(n).Value2
    
    Do
        
        ' avoid endless loop
        try = try + 1
        If try > 100 Then
             MsgBox "Could not solve in 100 tries", vbExclamation
             Exit Sub
        End If
        
        ' generate random selection
        ReDim ar(1 To n, 1 To 1)
        total = 0
        For i = 1 To Anzahl
            Do
                r = 1 + Int(n * Rnd())
            Loop Until ar(r, 1) = ""
            ar(r, 1) = Awert
            ' sum col B
            total = total + arB(r, 1)
        Next
        Range("C:C").Clear
        Range("C" & MinN).Resize(n) = ar
        
    Loop Until total >= 10 And total <= 20 ' check total in range
    
    MsgBox "Total=" & Format(total, "0.00"), vbInformation, try & " tries"
    
End Sub
user_127045930

You can use the Scripting.Dictionary object to check.

Given it's a "Dictionary", it requires that all keys are unique.

This is a crude implementation demonstrating the random filling of that dictionary with all numbers between 50 and 100.

Public Sub DoRandomize()
    Dim objUnique As Object, i As Long, lngRandom As Long
    Dim lngMin As Long, lngMax As Long, dblRandom As Double
    
    lngMin = 50: lngMax = 100
    
    Set objUnique = CreateObject("Scripting.Dictionary")
    
    Do While objUnique.Count <> (lngMax - lngMin) + 1
        Randomize objUnique.Count
        lngRandom = (Rnd(objUnique.Count) * (lngMax - lngMin)) + lngMin
        
        If Not objUnique.exists(lngRandom) Then
            Debug.Print "Adding ......... " & lngRandom
            objUnique.Add lngRandom, vbNull
        Else
            Debug.Print "Already used ... " & lngRandom
        End If
    Loop
End Sub

... you'd just need to pull out the relevant parts for your implementation but you can paste that code into your project, run it and see it work for yourself.

user_57720950

Ty Guys thats perfect =) i use this now and it works very nice + i understand my misconception

    Sub Zufallszahlen()

Const MaxN = 29
Const MinN = 1
Const Anzahl = 4
Const Awert = "X"

Dim ar, n As Long, r As Long
n = MaxN - MinN + 1
If n < Anzahl Then
    MsgBox "Min to Max range must be >= " & Anzahl
    Exit Sub
End If

ReDim ar(1 To n, 1 To 1)

For i = 1 To Anzahl
    Do
        r = 1 + Int(n * Rnd())
    Loop Until ar(r, 1) = ""
    ar(r, 1) = Awert
Next
Range("C:C").Clear
Range("C" & MinN).Resize(n) = ar

End Sub

Buts not finally completed. Can I include this part in another if?

This is intended to ensure that the values ​​of the cells to the left of the cells randomly marked with an x ​​add up to between 10 and 20, for example. Otherwise the random cells should be regenerated

user_181292010
Related