Loop to replace duplicates when generating random numbers

user_16635346 0
Viewed 69

I'm trying launch a set number of random numbers, according to how many I want. So far I did write a code, but I'm missing a loop to delete duplicates and replace those duplicates with new numbers, check for duplicates again, delete and repeat.

So far I have this but the loop part is giving me problems.

Sub PEM()

' Perguntas de Escolha Multipla
  
    Dim MyRange As Range
    Dim lMin As Long, lMax As Long
    Dim dRand As Double
    
    ' Se 1 questão
    If ActiveSheet.Range("B7").Value = 1 Then Set MyRange = ActiveSheet.Range("O1")
    ' Se 2 questão
    If ActiveSheet.Range("B7").Value = 2 Then Set MyRange = ActiveSheet.Range("O1:O2")
    ' Se 3 questão
    If ActiveSheet.Range("B7").Value = 3 Then Set MyRange = ActiveSheet.Range("O1:O3")
    ' Se 4 questão
    If ActiveSheet.Range("B7").Value = 4 Then Set MyRange = ActiveSheet.Range("O1:O4")
    ' Se 5 questão
    If ActiveSheet.Range("B7").Value = 5 Then Set MyRange = ActiveSheet.Range("O1:O5")
    ' Se 6 questão
    If ActiveSheet.Range("B7").Value = 6 Then Set MyRange = ActiveSheet.Range("O1:O6")
    ' Se 7 questão
    If ActiveSheet.Range("B7").Value = 7 Then Set MyRange = ActiveSheet.Range("O1:O7")
    ' Se 8 questão
    If ActiveSheet.Range("B7").Value = 8 Then Set MyRange = ActiveSheet.Range("O1:O8")
    ' Se 9 questão
    If ActiveSheet.Range("B7").Value = 9 Then Set MyRange = ActiveSheet.Range("O1:O9")
    ' Se 10 questão
    If ActiveSheet.Range("B7").Value = 10 Then Set MyRange = ActiveSheet.Range("O1:O10")
    ' Se 11 questão
    If ActiveSheet.Range("B7").Value = 11 Then Set MyRange = ActiveSheet.Range("O1:O11")
    ' Se 12 questão
    If ActiveSheet.Range("B7").Value = 12 Then Set MyRange = ActiveSheet.Range("O1:O12")
    ' Se 13 questão
    If ActiveSheet.Range("B7").Value = 13 Then Set MyRange = ActiveSheet.Range("O1:O13")
    ' Se 14 questão
    If ActiveSheet.Range("B7").Value = 14 Then Set MyRange = ActiveSheet.Range("O1:O14")
    ' Se 15 questão
    If ActiveSheet.Range("B7").Value = 15 Then Set MyRange = ActiveSheet.Range("O1:O15")
    ' Se 16 questão
    If ActiveSheet.Range("B7").Value = 16 Then Set MyRange = ActiveSheet.Range("O1:O16")
    ' Se 17 questão
    If ActiveSheet.Range("B7").Value = 17 Then Set MyRange = ActiveSheet.Range("O1:O17")
    ' Se 18 questão
    If ActiveSheet.Range("B7").Value = 18 Then Set MyRange = ActiveSheet.Range("O1:O18")
    ' Se 19 questão
    If ActiveSheet.Range("B7").Value = 19 Then Set MyRange = ActiveSheet.Range("O1:O19")
    ' Se 20 questão
    If ActiveSheet.Range("B7").Value = 20 Then Set MyRange = ActiveSheet.Range("O1:O20")
    ' Se 21 questão
    If ActiveSheet.Range("B7").Value = 21 Then Set MyRange = ActiveSheet.Range("O1:O21")
    ' Se 22 questão
    If ActiveSheet.Range("B7").Value = 22 Then Set MyRange = ActiveSheet.Range("O1:O22")
    ' Se 23 questão
    If ActiveSheet.Range("B7").Value = 23 Then Set MyRange = ActiveSheet.Range("O1:O23")
    ' Se 24 questão
    If ActiveSheet.Range("B7").Value = 24 Then Set MyRange = ActiveSheet.Range("O1:O24")
    ' Se 25 questão
    If ActiveSheet.Range("B7").Value = 25 Then Set MyRange = ActiveSheet.Range("O1:O25")
    ' Se 26 questão
    If ActiveSheet.Range("B7").Value = 26 Then Set MyRange = ActiveSheet.Range("O1:O26")
    ' Se 27 questão
    If ActiveSheet.Range("B7").Value = 27 Then Set MyRange = ActiveSheet.Range("O1:O27")
    ' Se 28 questão
    If ActiveSheet.Range("B7").Value = 28 Then Set MyRange = ActiveSheet.Range("O1:O28")
    ' Se 29 questão
    If ActiveSheet.Range("B7").Value = 29 Then Set MyRange = ActiveSheet.Range("O1:O29")
    ' Se 30 questão
    If ActiveSheet.Range("B7").Value = 30 Then Set MyRange = ActiveSheet.Range("O1:O30")
    ' Se 31 questão
    If ActiveSheet.Range("B7").Value = 31 Then Set MyRange = ActiveSheet.Range("O1:O31")
    ' Se 32 questão
    If ActiveSheet.Range("B7").Value = 32 Then Set MyRange = ActiveSheet.Range("O1:O32")
    ' Se 33 questão
    If ActiveSheet.Range("B7").Value = 33 Then Set MyRange = ActiveSheet.Range("O1:O33")
    ' Se 34 questão
    If ActiveSheet.Range("B7").Value = 34 Then Set MyRange = ActiveSheet.Range("O1:O34")
    ' Se 35 questão
    If ActiveSheet.Range("B7").Value = 35 Then Set MyRange = ActiveSheet.Range("O1:O35")
    ' Se 36 questão
    If ActiveSheet.Range("B7").Value = 36 Then Set MyRange = ActiveSheet.Range("O1:O36")
    ' Se 37 questão
    If ActiveSheet.Range("B7").Value = 37 Then Set MyRange = ActiveSheet.Range("O1:O37")
    ' Se 38 questão
    If ActiveSheet.Range("B7").Value = 38 Then Set MyRange = ActiveSheet.Range("O1:O38")
    ' Se 39 questão
    If ActiveSheet.Range("B7").Value = 39 Then Set MyRange = ActiveSheet.Range("O1:O39")
    ' Se 40 questão
    If ActiveSheet.Range("B7").Value = 40 Then Set MyRange = ActiveSheet.Range("O1:O40")
    ' Se 41 questão
    If ActiveSheet.Range("B7").Value = 41 Then Set MyRange = ActiveSheet.Range("O1:O41")
    ' Se 42 questão
    If ActiveSheet.Range("B7").Value = 42 Then Set MyRange = ActiveSheet.Range("O1:O42")
    ' Se 43 questão
    If ActiveSheet.Range("B7").Value = 43 Then Set MyRange = ActiveSheet.Range("O1:O43")
    ' Se 44 questão
    If ActiveSheet.Range("B7").Value = 44 Then Set MyRange = ActiveSheet.Range("O1:O44")
    ' Se 45 questão
    If ActiveSheet.Range("B7").Value = 45 Then Set MyRange = ActiveSheet.Range("O1:O45")
    ' Se 46 questão
    If ActiveSheet.Range("B7").Value = 46 Then Set MyRange = ActiveSheet.Range("O1:O46")
    ' Se 47 questão
    If ActiveSheet.Range("B7").Value = 47 Then Set MyRange = ActiveSheet.Range("O1:O47")
    ' Se 48 questão
    If ActiveSheet.Range("B7").Value = 48 Then Set MyRange = ActiveSheet.Range("O1:O48")
    ' Se 49 questão
    If ActiveSheet.Range("B7").Value = 49 Then Set MyRange = ActiveSheet.Range("O1:O49")
    ' Se 50 questão
    If ActiveSheet.Range("B7").Value = 50 Then Set MyRange = ActiveSheet.Range("O1:O50")
         
    ' Lança valor mínimo (1) e máximo (número total de perguntas sobre o tema na base de dados)
    lMin = 1
    lMax = ActiveSheet.Range("N1")

    Randomize

    For Each C In MyRange.Cells
        ' Calculate random value, where
        ' Value >= Min And Value <= Max
        dRand = Rnd * (lMax - lMin) + lMin

        ' Use the following line only if the random
        ' value should be an integer
        dRand = Int(dRand)

        C.Value = dRand
    
    Next C
 'Apagar duplicados
ActiveSheet.Range("O1:O50").RemoveDuplicates Columns:=Array(1)

 'Loop

For Each C In MyRange.Cells
Do While IsEmpty(C)

    If IsEmpty(C) Then
        dRand = Rnd * (lMax - lMin) + lMin
        ' Calculate random value, where
        ' Value >= Min And Value <= Max

        ' Use the following line only if the random
        ' value should be an integer
        dRand = Int(dRand)

        C.Value = dRand

   Loop
      
End Sub
vba excel
1 Answers

Since you have Office 365 we can use RANDARRAY:

You can put the formula directly in O1 and it will spill:

=INDEX(UNIQUE(RANDARRAY(1000,1,1,N1,TRUE)),SEQUENCE(B7))

enter image description here

Or if you really want code then:

Sub PEM()
    Dim rng As Range
    Set rng = ActiveSheet.Range("O1:O50")
    rng.ClearContents
    ActiveSheet.Range("O1").Formula2 = "=INDEX(UNIQUE(RANDARRAY(1000,1,1,N1,TRUE)),SEQUENCE(B7))"
    rng.Value = rng.Value
End Sub

It will put the formula in then it will replace it with just the value so it remains static.

user_48515900
Related