VBA for random non repeating numbers...help please!

[vbull]

Hi,

I'm running into problems with a wee project I'm working on. It involves selecting items for auditing from a list, randomly without repeats.

In cell A1 I have the number of reports required to be selected - this could be anything from 1 - 1000.

A2 has the maximum number of the range that I want the random numbers to lie in, the minimum being 1.

I would like to populate a column of numbers, from B1 down with random selections between 1 and the maximum (from cell A2) without any repeats.

So if A1 contains '20' and A2 contains '100' I would like to generate 20 random numbers that lie between 1 and 100 and have these copied to cells B1 to B100.

I tried formulaes but there doesn't seem to be an easy way without the possiblity of repeats. So I've attempeted some VB but can't get that to work either.

Could anyone provide a possible way of getting this to work.

Thanks in advance

 

[jbeaucaire]

RANDOM NUMBER SELECTIONS FROM A RANGE

I've added a page to my sample sheet showing exactly what you're looking to do.

Jerry Beaucaire's Excel Tools
​

(The file you want is RandomNumGenerator.xls)


This is the non-macro arrangement you wanted, each time you press F9 you will get a new set of values in column B.

 

[Trebor76]

Hi vbull,

And here's my VBA solution (which I must say was more tricky than I initially envisaged):

Sub Macro1()

    'Macro written by Trebor76, Jun 2 2010 to extract a range of unique numbers.

    Dim lngNumberFrom As Long, _
        lngNumberTo As Long, _
        lngRandomNumber As Long, _
        lngCellExtract As Long, _
        lngRowNumber As Long
    
    Application.ScreenUpdating = False

    lngNumberFrom = 1 'Minimum number in range
    lngNumberTo = Range("A2").Value 'Maximum number in range
    lngNumberExtract = Range("A1").Value 'Amount of unique numbers to extract
    lngRowNumber = 1 'Initial row extract number
    
    'Clear any existing entries in Column B.
    Columns("B").ClearContents
    
    For lngRandomNumber = 1 To lngNumberExtract
        lngCellExtract = Int((lngNumberTo + 1 - lngNumberFrom) * Rnd + lngNumberFrom)
            'If the random number generated is unique, then...
            If Evaluate("COUNTIF(B1:B" & lngNumberExtract & "," & lngCellExtract & ")") = 0 Then
                '...put it into the next available row in Column B.
                Range("B" & lngRowNumber).Value = lngCellExtract
                lngRowNumber = lngRowNumber + 1
            'Else...
            Else
                '...ignore that number and try again.
                lngRandomNumber = lngRandomNumber - 1
            End If
    Next lngRandomNumber
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

 

[Armando Montes]

Don't remmeber the source for credit but try this one:

Function RandLotto(Bottom As Integer, Top As Integer, _
                    Amount As Integer) As String
    Dim iArr As Variant
    Dim i As Integer
    Dim r As Integer
    Dim temp As Integer
    
    Application.Volatile
    
    ReDim iArr(Bottom To Top)
    For i = Bottom To Top
        iArr(i) = i
    Next i
    
    For i = Top To Bottom + 1 Step -1
        r = Int(Rnd() * (i - Bottom + 1)) + Bottom
        temp = iArr(r)
        iArr(r) = iArr(i)
        iArr(i) = temp
    Next i
    
    For i = Bottom To Bottom + Amount - 1
        RandLotto = RandLotto & " " & iArr(i)
    Next i
    
    RandLotto = Trim(RandLotto)
    
End Function

 

[vbull]

Hi vbull,

And here's my VBA solution (which I must say was more tricky than I initially envisaged):

Sub Macro1()

    'Macro written by Trebor76, Jun 2 2010 to extract a range of unique numbers.

    Dim lngNumberFrom As Long, _
        lngNumberTo As Long, _
        lngRandomNumber As Long, _
        lngCellExtract As Long, _
        lngRowNumber As Long
    
    Application.ScreenUpdating = False

    lngNumberFrom = 1 'Minimum number in range
    lngNumberTo = Range("A2").Value 'Maximum number in range
    lngNumberExtract = Range("A1").Value 'Amount of unique numbers to extract
    lngRowNumber = 1 'Initial row extract number
    
    'Clear any existing entries in Column B.
    Columns("B").ClearContents
    
    For lngRandomNumber = 1 To lngNumberExtract
        lngCellExtract = Int((lngNumberTo + 1 - lngNumberFrom) * Rnd + lngNumberFrom)
            'If the random number generated is unique, then...
            If Evaluate("COUNTIF(B1:B" & lngNumberExtract & "," & lngCellExtract & ")") = 0 Then
                '...put it into the next available row in Column B.
                Range("B" & lngRowNumber).Value = lngCellExtract
                lngRowNumber = lngRowNumber + 1
            'Else...
            Else
                '...ignore that number and try again.
                lngRandomNumber = lngRandomNumber - 1
            End If
    Next lngRandomNumber
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

Spot on Robert - just what I was after. Nice use of countif to check if the value exists, and to ignore if it does. This was exactly what I was having trouble with and your solution is nice and tidy.

Thanks again - helped me out of a jam (and I still have some hair left!).

 

[Trebor76]

I'm glad it was what you were after

One thing you might consider adding would be a check that if the number in A1 is greater than A2 then alert the user that this cannot be the case and quit the routinue.