Non-repeating random number generator? - vba

I created a trivia game using visual basic for applications (Excel) that chooses questions by going through a case statement where the cases are numbers. I have the program randomly select a number from 1 to the max amount of questions there are. Using this method, the game repeats questions.
Is there a way to make something that generates numbers randomly (different results every time) and doesn't repeat a number more than once? And after it's gone through all the numbers it needs to execute a certain code. (I'll put in code that ends the game and displays the number of questions they got right and got wrong)
I thought of a few different ways to do this, however I couldn't even begin to think of what the syntax might be.

Sounds like you need an Array Shuffler!
Check out the below link -
http://www.cpearson.com/excel/ShuffleArray.aspx
Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim Arr() As Variant
Randomize
L = UBound(InArray) - LBound(InArray) + 1
ReDim Arr(LBound(InArray) To UBound(InArray))
For N = LBound(InArray) To UBound(InArray)
Arr(N) = InArray(N)
Next N
For N = LBound(InArray) To UBound(InArray)
J = CLng(((UBound(InArray) - N) * Rnd) + N)
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
Next N
ShuffleArray = Arr
End Function
Sub ShuffleArrayInPlace(InArray() As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArrayInPlace
' This shuffles InArray to random order, randomized in place.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
Randomize
For N = LBound(InArray) To UBound(InArray)
J = CLng(((UBound(InArray) - N) * Rnd) + N)
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End Sub

Here's yet another take. It generates an array of unique, random longs.
In this example, I use 1 to 100. It does this by using the collection object. Then you can just do a normal loop through each array element in qArray without the need to randomize more than once.
Sub test()
Dim qArray() As Long
ReDim qArray(1 To 100)
qArray() = RandomQuestionArray
'loop through your questions
End Sub
Function RandomQuestionArray()
Dim i As Long, n As Long
Dim numArray(1 To 100) As Long
Dim numCollection As New Collection
With numCollection
For i = 1 To 100
.Add i
Next
For i = 1 To 100
n = Rnd * (.Count - 1) + 1
numArray(i) = numCollection(n)
.Remove n
Next
End With
RandomQuestionArray = numArray()
End Function

I see you have an answer, I was working on this but lost my internet connection. Anyway here is another method.
'// Builds a question bank (make it a hidden sheet)
Sub ResetQuestions()
Const lTotalQuestions As Long = 300 '// Total number of questions.
With Range("A1")
.Value = 1
.AutoFill Destination:=Range("A1").Resize(lTotalQuestions), Type:=xlFillSeries
End With
End Sub
'// Gets a random question number and removes it from the bank
Function GetQuestionNumber()
Dim lCount As Long
lCount = Cells(Rows.Count, 1).End(xlUp).Row
GetQuestionNumber = Cells(Int(lCount * Rnd + 1), 1).Value
Cells(lRandom, 1).Delete
End Function
Sub Test()
Msgbox (GetQuestionNumber)
End Sub

For whatever it's worth here is my stab at this question. This one uses a boolean function instead of numerical arrays. It's very simple yet very fast. The advantage of it, which I'm not saying is perfect, is an effective solution for numbers in a long range because you only ever check the numbers you have already picked and saved and don't need a potentially large array to hold the values you have rejected so it won't cause memory problems because of the size of the array.
Sub UniqueRandomGenerator()
Dim N As Long, MaxNum As Long, MinNum As Long, Rand As Long, i As Long
MinNum = 1 'Put the input of minimum number here
MaxNum = 100 'Put the input of maximum number here
N = MaxNum - MinNum + 1
ReDim Unique(1 To N, 1 To 1)
For i = 1 To N
Randomize 'I put this inside the loop to make sure of generating "good" random numbers
Do
Rand = Int(MinNum + N * Rnd)
If IsUnique(Rand, Unique) Then Unique(i, 1) = Rand: Exit Do
Loop
Next
Sheet1.[A1].Resize(N) = Unique
End Sub
Function IsUnique(Num As Long, Data As Variant) As Boolean
Dim iFind As Long
On Error GoTo Unique
iFind = Application.WorksheetFunction.Match(Num, Data, 0)
If iFind > 0 Then IsUnique = False: Exit Function
Unique:
IsUnique = True
End Function

Related

VBA Function returning #VALUE when called within excel

Below is a function that is supposed to return a random value between 1 and 10 that is not already in column A. It works fine in terms of finding the random value and exiting the loop but in excel when called using =Ang() the function returns #Value! as below.
Function Ang()
i = 0
Do
i = Application.WorksheetFunction.RandBetween(1, 10)
Ang = i
MsgBox Ang
Loop While Application.WorksheetFunction.IfNa(Application.WorksheetFunction.Match(i, Worksheets("Sheet2").Range("A:A"), 0), 0)
End Function
The issue is WorksheetFunction.Match will stop the code with an error if it is not found.
Use Application.Match instead:
Function Ang() as Long
Dim i as Long
i = 0
Do
i = Application.WorksheetFunction.RandBetween(1, 10)
Ang = i
MsgBox Ang
Loop While Not IsError(Application.Match(i, Worksheets("Sheet2").Range("A:A"), 0))
End Function
Or
Function Ang()
i = 0
Do
i = Application.WorksheetFunction.RandBetween(1, 10)
Ang = i
MsgBox Ang
Loop While Application.WorksheetFunction.CountIf(Worksheets("Sheet2").Range("A:A"), i)
End Function
Rather than hard-wiring in the range of numbers to avoid, why not make it an argument to the function?
Function NewRandom(R As Range, a As Long, b As Long) As Variant
'returns a random number in a,b which isn't in range R
Dim i As Long, k As Long, rand As Long
Dim c As Range
Dim avoid As Variant
Dim count As Long
ReDim avoid(a To b) As Boolean
For Each c In R.Cells
k = c.Value
If a <= k And k <= b Then
avoid(k) = True
count = count + 1
End If
Next c
If count = b - a + 1 Then 'error condition!
NewRandom = CVErr(xlErrValue)
Else
Do
rand = Application.WorksheetFunction.RandBetween(a, b)
Loop While avoid(rand)
NewRandom = rand
End If
End Function
Used like:
The function guards against an infinite loop. If in B1 I used =NewRandom(A1:A7,1,5) then the error #VALUE! would be returned. The code assumes that the range from a to b is not so large as to be a significant memory drain. If it is, then the array avoid can be replaced by a dictionary.

gas behavior in VBA

my project is to predict non-ideal gas movement, so i wrote this code to give every molecule a specific number, but it keeps repeating numbers (i used randbetween)
how do i chnge it so it wont repeat the same number?
Sub Rand_Number()
'áåçø 20 àçåæ ùì îñôøé äîåì÷åìåú
Dim RandNum As Long
Dim k As Long
Dim Mone As Integer
Mone = 0
Num_molecules = Sheets("Data").Range("A14").Value
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
For j = 1 To Num_molecules * 0.2
If IsEmpty(Sheets("rand").Cells(1, 1)) = True Then
Sheets("rand").Cells(1, 1) = RandNum
Else
i = 1
'RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Do 'Until IsEmpty(Sheets("rand").Cells(i, 1)) = True
If Sheets("rand").Cells(i, 1) = RandNum Then
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Do Until RandNum = Cells(i, 1) Or IsEmpty(Cells(i, 1)) = True
If RandNum = Sheets("rand").Cells(i, 1) Then
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Else
i = i + 1
End If
Loop
ElseIf IsEmpty(Sheets("rand").Cells(i, 1)) = False Then
i = i + 1
Else
Sheets("rand").Cells(i, 1) = RandNum
Exit Do
End If
Loop
End If
Next j
End Sub
Generation of numbers until all numbers from the range are generated. It is inefficient as towards the end of the algorithm most random numbers become a "miss", but it is still more efficient than collection's remove method below.
Sub uniqRndMissedHits()
Dim lb As Long: lb = 1 ' lower bound
Dim ub As Long: ub = 1000 ' upper bound
' populate collection with numbers starting from lb to ub
Dim i As Long
Dim c As New Collection
' iterate while we haven't generated all the random numbers
' in the specified range
While c.Count < ub - lb + 1
i = Int((ub - lb + 1) * Rnd + lb)
If Not contains(c, CStr(i)) Then
c.Add i, CStr(i)
Debug.Print i ' this is your unique random number from the
' remaining in the collection
End If
Wend
End Sub
Function contains(col As Collection, key As String) As Boolean
On Error Resume Next
col.Item key
contains = (Err.Number = 0)
On Error GoTo 0
End Function
This example generates a guaranteed unique (i.e. previously not generated) values, but Remove method of the Collection makes it inefficient for large number of simulations.
Sub uniqRnd()
Dim lb As Long: lb = 1 ' lower bound
Dim ub As Long: ub = 1000 ' upper bound
' populate collection with numbers starting from lb to ub
Dim i As Long
Dim c As New Collection
For i = lb To ub: c.Add i: Next
' randomly pick the number and (!) remove it from the
' collection at the same time so it won't be repeated
While c.Count > 0
lb = 1
ub = c.Count
i = Int((ub - lb + 1) * Rnd + lb)
Debug.Print c(i) ' this is your unique random number from the
' remaining in the collection
c.Remove i
Wend
End Sub
Comparison of performance of all the methods in this answer can be found in this GitHub Gist Excel VBA: Generate complete set of unique random numbers
I'd recommend using a dictionary to keep track of the random numbers that have been generated so far. If the number doesn't exist in the dictionary you can proceed with the simulation, otherwise you could generate a new random number (this would be the Else condition)
Using a dictionary is very fast for doing the lookup.
Here's a code sample of how to work with a dictionary.
Public Sub DictionaryExample()
Dim myDict As Object: Set myDict = CreateObject("Scripting.Dictionary")
Dim myRand As Long
Dim i As Long
For i = 1 To 10000
myRand = WorksheetFunction.RandBetween(1, 10000)
If myDict.exists(myRand) = False Then ' The random number doesn't exist in the previous items added
'If it doesn't exist, add it to the dictionary
myDict.Add myRand, myRand 'First parameter is the key, or the unique value
'The second parameter is the value associated with the key, the lookup value
Else
'Do something here when it does exist
End If
Next i
End Sub

VBA - Setting multidimensional array values in one line

Right, so using Python I would create a multidimensional list and set the values on one line of code (as per the below).
aryTitle = [["Desciption", "Value"],["Description2", "Value2"]]
print(aryTitle[0,0] + aryTitle[0,1])
I like the way I can set the values on one line. In VBA I am doing this by:
Dim aryTitle(0 To 1, 0 To 1) As String
aryTitle(0, 0) = "Description"
aryTitle(0, 1) = "Value"
aryTitle(1, 0) = "Description2"
aryTitle(1, 1) = "Value2"
MsgBox (aryTitle(0, 0) & aryTitle(0, 1))
Is there a way to set the values in one line of code?
Not natively, no. But you can write a function for it. The only reason Python can do that is someone wrote a function to do it. The difference is that they had access to the source so they could make the syntax whatever they like. You'll be limited to VBA function syntax. Here's a function to create a 2-dim array. It's not technically 'one line of code', but throw it in your MUtilities module and forget about it and it will feel like one line of code.
Public Function FillTwoDim(ParamArray KeyValue() As Variant) As Variant
Dim aReturn() As Variant
Dim i As Long
Dim lCnt As Long
ReDim aReturn(0 To ((UBound(KeyValue) + 1) \ 2) - 1, 0 To 1)
For i = LBound(KeyValue) To UBound(KeyValue) Step 2
If i + 1 <= UBound(KeyValue) Then
aReturn(lCnt, 0) = KeyValue(i)
aReturn(lCnt, 1) = KeyValue(i + 1)
lCnt = lCnt + 1
End If
Next i
FillTwoDim = aReturn
End Function
Sub test()
Dim vaArr As Variant
Dim i As Long
Dim j As Long
vaArr = FillTwoDim("Description", "Value", "Description2", "Value2")
For i = LBound(vaArr, 1) To UBound(vaArr, 1)
For j = LBound(vaArr, 2) To UBound(vaArr, 2)
Debug.Print i, j, vaArr(i, j)
Next j
Next i
End Sub
If you supply an odd number of arguments, it ignores the last one. If you use 3-dim arrays, you could write a function for that. You could also write a fancy function that could handle any dims, but I'm not sure it's worth it. And if you're using more than 3-dim arrays, you probably don't need my help writing a function.
The output from the above
0 0 Description
0 1 Value
1 0 Description2
1 1 Value2
You can write a helper function:
Function MultiSplit(s As String, Optional delim1 As String = ",", Optional delim2 As String = ";") As Variant
Dim V As Variant, W As Variant, A As Variant
Dim i As Long, j As Long, m As Long, n As Long
V = Split(s, delim2)
m = UBound(V)
n = UBound(Split(V(0), delim1))
ReDim A(0 To m, 0 To n)
For i = 0 To m
For j = 0 To n
W = Split(V(i), delim1)
A(i, j) = Trim(W(j))
Next j
Next i
MultiSplit = A
End Function
Used like this:
Sub test()
Dim A As Variant
A = MultiSplit("Desciption, Value; Description2, Value2")
Range("A1:B2").Value = A
End Sub

function does not pass the value

please help me with this problem. I'm just starting to use VBA and after searching the forum was not able to find a solution. I have 1000 single digit numbers in my spreadsheet. 20 rows of 50 numbers in each. my program suppose to find the largest product. For some reason my final answer is 0. I've done some debugging and the program goes through all the loops and iterations as expected. I suspect that my function does not pass the value back to my main
Public Sub problem8()
Dim product, i, j, maxproduct As Long
maxproduct = product = 1
For i = 1 To 20
For j = 1 To 50
product = calcproduct(i, j)
If product > maxproduct Then maxproduct = product
Next j
Next i
Range("AY1").Value = maxproduct
End Sub
Function calcproduct(ByVal a As Long, ByVal b As Long) As Long
Dim i, j, count As Long
counter = calcproduct = 1
For i = a To 20
For j = b To 50
calcproduct = Cells(i, j).Value * calcproduct
counter = counter + 1
If counter = 13 Then Exit Function
Next j
Next i
End Function
Change:
Dim product, i, j, maxproduct As Long
to:
Dim product as long, i as long, j as long, maxproduct As Long
and:
Dim i, j, count As Long
to:
Dim i as long, j as long, count As Long
I used to think putting it on the end applied it to everything on the row but it doesn't and I encountered a similar issue to you.
I might add though, the way you have done this (assigning i and j to new variables a and b then using i and j in the second routine) is extremely confusing and I would strongly recommend against it.
First off, this is the wrong way to express what you are trying to accomplish.
maxproduct = product = 1
This says "maxproduct is equal to False". product was just declared so it is for all intents and purposes a zero and not equal to 1. You wanted to say,
maxproduct = 1
product = 1
If you really need to put those last two on a single line then use a colon like this,
maxproduct = 1: product = 1
The same holds true for the similar syntax in the function.
Now it is important to understand that VBA treats True as -1 and False as 0 (zero). Since you are essentially initializing maxproduct and product as zeroes, you can multiply anything you want by it and you will still end up with zero. Again, the same holds true for the way this similar variable assignment was handled in the function.
Here is my take on your project.
Option Explicit
Public Const maxA As Long = 20
Public Const maxB As Long = 50
Public Const cntC As Long = 13
Public Sub problem8()
Dim product As Long, i As Long, j As Long, maxproduct As Long
maxproduct = 1: product = 1
For i = 1 To maxA
For j = 1 To maxB
product = calcproduct(i, j)
If product > maxproduct Then maxproduct = product
Next j
Next i
Range("AY1").Value = maxproduct
End Sub
Function calcproduct(ByVal a As Long, ByVal b As Long) As Long
Dim i As Long, j As Long, counter As Long
counter = 1: calcproduct = 1
For i = a To maxA
For j = b To maxB
calcproduct = Cells(i, j).Value * calcproduct
counter = counter + 1
If counter = cntC Then Exit Function
Next j
Next i
End Function
I moved the limits to public constants which make it easier to modify for different sized regions. In your function you declared a count then started using a var called counter so I changed that to suit. As mentioned in another post, the variable declaration needs to be specific or you end up with a bunch of variants and a few longs.

VBA comparing multiple variables

There any way to compare multiple variables in VBA? For example:
Dim x As Integer
Dim y As Integer
Dim z As Integer
x = 99
y = 2
z = 3
I would like to return the smallest of the values.
I understand I could use select case x > y for all possible permutations but that seems unwieldy for more than 3 variables.
I have tried the worksheet function
solution = Application.WorksheetFunction.Min(x, y, z)
but that returns 2 and I would like it to return the variable name to be passed to another function.
many thanks,
Edit: My apologies if this was confusing, I am still a VBA novice. Here's my problem a little more generally:
I have a list of codes that correspond to names, many names per code. I want to loop through every name per code and count the number of instances that name appears on a list and choose the name with the LEAST occurrences. (could be 0 or could be the same as another name). obviously if there were 2 names it would be easy to do a if x>y then but I'm stumped as for comparing more than 3. Thanks for reading.
Use a public array rather than multiple variables. This will make it easy to iterate through them all and get the highest value, as well as reference the variable with the highest value later on:
Public myArray(0 To 2) As Integer
Public index As Integer
Public Sub calcMin()
Dim i As Integer
Dim maxValue As Integer
myArray(0) = 99
myArray(1) = 2
myArray(2) = 3
For i = 0 To UBound(myArray)
If myArray(i) < maxValue Then
maxValue = myArray(i)
index = i
End If
Next i
End Sub
Function yourFunction(valueToPass As Integer)
'your function's code here
End Function
Then pass the variable to yourFunction like so: yourFunction(myArray(index))
Same idea as Mike's but with an example to call a sub with the min value found:
Sub main()
Dim arrComp(2) As Integer
arrComp(0) = 99
arrComp(1) = 2
arrComp(2) = 3
'It is important to initialize the tmpVal to a value from the array
'to consider the chance where negative and positive values are used
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp))
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i) < tmpVal Then
tmpVal = arrComp(i)
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
Sub showMinVal(MinVal As Integer)
MsgBox "The min value is " & MinVal
End Sub
Or, a workaround if you want the name associated to the value, you could define a new Type:
'Types must be declared at the top of the module
Type tVarName
varName As String
varVal As Integer
End Type
Sub main()
Dim arrComp(2) As tVarName
arrComp(0).varName = "x"
arrComp(0).varVal = 99
arrComp(1).varName = "y"
arrComp(1).varVal = 2
arrComp(2).varName = "z"
arrComp(2).varVal = 3
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp)).varVal
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i).varVal < tmpVal Then
tmpVal = arrComp(i).varVal
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
'Sub showing min value along with the name associated to it
Sub showMinVal(MinVal As tVarName)
MsgBox "The min value is " & MinVal.varName & " = " & MinVal.varVal
End Sub