Start:
Randomize()
'randomValue = CInt(Math.Floor((upperbound - lowerbound + 1) * Rnd())) + lowerbound
Dim value As Integer = CInt(Int((2 * Rnd()) + 1))
intNumber = value - 1
Dim y As Integer
For y = 0 To 1
' Check arrNumber (y)
'If intnumber has already been selected,
'Then go and select another one.
If intNumber = arrNumber(y) Then
GoTo Start
End If
Next y
im am getting same value of value variable again
As you have posted an incomplete and non-working code sample, it's difficult to tell where your problem is.
I reduced your code to the core:
Option Explicit
Sub Randomize()
Dim value As Integer
Dim i As Integer
For i = 1 To 100
value = CInt(Int((2 * Rnd()) + 1))
Debug.Print value
Next i
End Sub
This code randomly prints the values 1 and 2 to the Immediate window (press CTRL-G to open it). The small range [1, 2] is due to the scaling with the value 2. It could easily be increased.
So Rnd() seems to just work fine.
Related
If I want to create a random order to select another pair from my image. , not repeating the random pair i've previously picked, i.e. so that once i've gone through 56 random unique images i.e. 26 random pairs, the game is over, and reset to my original 57 images and start picking random pairs again. Can this be done in VBA Powerpoint?
This is the sub I am using:
Sub RandomImage()
Dim i As Long
Dim posLeft As Long
For i = 1 To 2
Randomize
RanNum% = Int(57 * Rnd) + 1
Path$ = ActivePresentation.Path
FullFileName$ = Path$ + "/" + CStr(RanNum%) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(FileName:=FullFileName$, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=posLeft, Top:=100, Width:=400)
Next
End Sub
Please, try the next function. It uses an array built from 1 to maximum necessary/existing number. It returns the RND array element and then eliminate it from the array, next time returning from the remained elements:
Please, copy the next variables on top of the module keeping the code you use (in the declarations area):
Private arrNo
Private Const maxNo As Long = 57 'maximum number of existing pictures
Copy the next function code in the same module:
Function ReturnUniqueRndNo() As Long
Dim rndNo As Long, filt As String, arr1Based, i As Long
If Not IsArray(arrNo) Then
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
End If
If UBound(arrNo) = 0 Then
ReturnUniqueRndNo = arrNo(0)
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
MsgBox "Reset the used array..."
Exit Function
End If
Randomize
rndNo = Int((UBound(arrNo) - LBound(arrNo) + 1) * Rnd + LBound(arrNo))
ReturnUniqueRndNo = arrNo(rndNo) 'return the array element
filt = arrNo(rndNo) & "$$$": arrNo(rndNo) = filt 'transform the array elem to be removed
arrNo = filter(arrNo, filt, False) 'eliminate the consumed number, but returning a 0 based array...
End Function
The used array is reset when reaches its limit and send a message.
It may be tested using the next testing Sub:
Sub testReturnUniqueRndNo()
Dim uniqueNo As Long, i As Long
For i = 1 To 2
uniqueNo = ReturnUniqueRndNo
Debug.Print uniqueNo
Next i
End Sub
In order to test it faster, you may modify maxNo at 20...
After testing it, you have to modify your code in the next way:
Sub RandomImage()
Dim i As Long, posLeft As Long, RanNum%, path$, fullFileName$
path = ActivePresentation.path
For i = 1 To 2
RanNum = ReturnUniqueRndNo
fullFileName = path + "/" + CStr(RanNum) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(fileName:=fullFileName, _
LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, left:=posLeft, top:=100, width:=400)
Next
End Sub
Please, test it and send some feedback. I did not test it in Access, but it should work...
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
I use the following function
CInt(Math.Floor((99999999 - 10000000 + 1) * Rnd())) + 10000000)
To get random numbers with length of 8 digits...
Ok I get sum of different numbers with the length I want when I run this function in debugging mode
But when I run my program that function
Dim rguun As String = CInt(Math.Floor((99999999 - 10000000 + 1) * Rnd())) + 10000000)
Always gives me back the same number
Why is that happen?
Public Sub randomnumber()
Dim rndNumber As String = ""
Dim rnd As New Random
For n As Integer = 0 To 7
rndNumber &= Rnd.Next(0, 9)
Next
End Sub
The add is working correctly
Private Sub AddColumnToTableLayout()
Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, (100 / m_TblLyBtnHost.ColumnCount)))
For iColumnStyle As Integer = 0 To Me.m_TblLyBtnHost.ColumnStyles.Count - 1
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnStyle).SizeType = SizeType.Percent
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnStyle).Width = 100 / Me.m_TblLyBtnHost.ColumnCount
Next
'For iColumns As Integer = 0 To m_TblLyBtnHost.ColumnCount - 1
' Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, (100 / m_TblLyBtnHost.ColumnCount)))
'Next
'Insert buttons for each of the new row ends
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
m_btnMy = New MyButton.MyButton
Me.SetDefaultsOnMyButtonMyButton(m_btnMy, Me.m_TblLyBtnHost.ColumnCount, iRowIndex)
Me.m_TblLyBtnHost.Controls.Add(m_btnMy, Me.m_TblLyBtnHost.ColumnCount, iRowIndex)
Next
End Sub
The MyButton.MyButton is declared in the the class for the UserControl as
Friend WithEvents m_btnMy As MyButton.MyButton
The Remove function however isn't
Private Sub RemoveColumnFromTableLayout()
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
Dim Ctrl As MyButton.MyButton = Me.m_TblLyBtnHost.GetControlFromPosition(iRowIndex, Me.m_TblLyBtnHost.ColumnCount - 1)
Me.m_TblLyBtnHost.Controls.Remove(Ctrl)
Next
Me.m_TblLyBtnHost.ColumnStyles.RemoveAt(Me.m_TblLyBtnHost.ColumnCount - 1)
For iColumnIndex As Integer = 0 To Me.m_TblLyBtnHost.ColumnStyles.Count - 1
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnIndex).Width = 100 / Me.m_TblLyBtnHost.ColumnCount
Next
End Sub
In stepping through RemoveColumnFromTableLayout() I noticed that GetControlFromPosition is returning "Nothing". I started with a 2x2 matrix and after adding a column I correctly have a 2x3 matrix with button. After a remove I incorrect have a 3x2 matrix of the same button set. I tried using a dispose on the control before I realized that the GetControl was returning "Nothing".
Thanks for any help.
Some general notes:
You have to explicitly increment/decrement the ColumnCount()
property.
The ColumnStyle() Width property does NOT need to be an actual
computed percentage. Simply make all the columns have the same
value. I've used whatever value is in the first column. With that
in mind, you don't have to change any of the Widths when a column is
removed, since they are all the same value already.
You had an "off by one" error in the Column value for the Add()
routine.
In the Remove() routine, your row/col parameters were Reversed in
the GetControlFromPosition() call.
Here's the revised code:
Private Sub AddColumnToTableLayout()
Me.m_TblLyBtnHost.ColumnCount = Me.m_TblLyBtnHost.ColumnCount + 1
Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, Me.m_TblLyBtnHost.ColumnStyles(0).Width))
'Insert buttons for each of the new row ends
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
m_btnMy = New MyButton.MyButton
Me.SetDefaultsOnMyButtonMyButton(m_btnMy, Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex)
Me.m_TblLyBtnHost.Controls.Add(m_btnMy, Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex)
Next
End Sub
Private Sub RemoveColumnFromTableLayout()
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
Me.m_TblLyBtnHost.GetControlFromPosition(Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex).Dispose()
Next
Me.m_TblLyBtnHost.ColumnStyles.RemoveAt(Me.m_TblLyBtnHost.ColumnCount - 1)
Me.m_TblLyBtnHost.ColumnCount = Me.m_TblLyBtnHost.ColumnCount - 1
End Sub
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