I have found this VBA script (running in powerpoint) and I just wanted to know how to stop numbers from being repeated. I did some google searches and I think the solution would be to create an array, and have the selected number go into the array. The script would then generate a new number as long as it skips all numbers in the array.
I'm just not sure how to implement this as I do not know VBA.
here is the script:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim chosenNum As Integer
Dim I As Integer
Dim k As Integer
Sub randomNumber()
lowRand = 1
maxRand = 10
Randomize
For k = 1 To 10
chosenNum = Int((maxRand - lowRand) * Rnd) + lowRand
With ActivePresentation.SlideShowWindow.View.Slide.Shapes(2).TextFrame.TextRange
.Text = chosenNum
End With
For I = 1 To 1
Sleep (50)
DoEvents
Next
Next
End Sub
Any thoughts? Thanks.
This will collect 10 unique single digit numbers (0 to 9) into a string and then split them into an array. As each is returned to the slide, 1 is added so the resut is 1 to 10.
Sub randomNumber()
Dim lowRand As Long, maxRand As Long, strNum As String, chosenNum As String
Dim k As Long, vNUMs As Variant
lowRand = 0: maxRand = 10: strNum = vbNullString
Randomize
For k = 1 To 10
chosenNum = Format(Int((maxRand - lowRand) * Rnd) + lowRand, "0")
Do While CBool(InStr(strNum, chosenNum))
chosenNum = Format(Int((maxRand - lowRand) * Rnd) + lowRand, "0")
Loop
strNum = strNum & chosenNum
Next k
vNUMs = Split(StrConv(strNum, vbUnicode), Chr(0))
For k = LBound(vNUMs) To UBound(vNUMs)
With ActivePresentation.SlideShowWindow.View.Slide.Shapes(2).TextFrame.TextRange
.Text = vNUMs(k) + 1
End With
For I = 1 To 1
Sleep (50)
DoEvents
Next
Next k
End Sub
I just wrote this to help you. The function is designed to return random integer numbers in the range you specify until all numbers in the range have been returned when it will then return -1. There is a test sub included to show how to use the function to get all numbers from 5 to 10.
'----------------------------------------------------------------------------------
' Copyright (c) 2015 YOUpresent Ltd.
' Source code is provide under Creative Commons Attribution License
' This means you must give credit for our original creation in the following form:
' "Includes code created by YOUpresent Ltd. (YOUpresent.co.uk)"
' Commons Deed # http://creativecommons.org/licenses/by/3.0/
' License Legal # http://creativecommons.org/licenses/by/3.0/legalcode
'----------------------------------------------------------------------------------
Option Explicit
Option Base 0 ' Explicitly set the lower bound of arrays to 0
Private iUsed As Integer ' count of all used numebrs
Public arrTracking() As String
'----------------------------------------------------------------------------------
' Purpose: Returns a random number in a specified range without repeats
' Inputs: iLow - integer representing the low end of the range
' iHigh - integer representing the high end of the range
' bReset - boolean flag to optionally reset the array
' Outputs: returns an integer number or -1 if all numbers have been used
' Example first call: myNum = GetRandomNumber(10, 5, true)
' Example subsequent call: myNum = GetRandomNumber(10, 5)
'----------------------------------------------------------------------------------
Function GetRandomNumber(iLow As Integer, iHigh As Integer, Optional bReset As Boolean) As Integer
Dim iNum As Integer ' random number to be generated
Dim InArray As Boolean ' flag to test if number already used
Randomize
' Reset the tracking array as required
If bReset Then ReDim arrTracking(iHigh - iLow)
' If we've used all of the numbers, return -1 and quit
If iUsed = iHigh - iLow + 1 Then
GetRandomNumber = -1
Exit Function
End If
' Repeat the random function until we find an unused number and then
' update the tracking array, uncrease the counter and return the number
Do While Not InArray
iNum = Fix(((iHigh - iLow + 1) * Rnd + iLow))
If arrTracking(iNum - iLow) = "" Then
arrTracking(iNum - iLow) = "used"
iUsed = iUsed + 1
InArray = True
GetRandomNumber = iNum
Else
'Debug.Print iNum & " used"
End If
Loop
End Function
'----------------------------------------------------------------------------------
' Purpose: Test sub to get all random numbers in the range 5 to 10
' Inputs: None
' Outputs: Debug output of 6 numbers in the range 5 to 10 in then immediate window
'----------------------------------------------------------------------------------
Sub GetAllRand()
Dim iRndNum As Integer
' Get the initial number, restting the tracking array in the process
iRndNum = GetRandomNumber(5, 10, True)
Debug.Print iRndNum
Do While Not iRndNum = -1
iRndNum = GetRandomNumber(5, 10)
Debug.Print iRndNum
Loop
End Sub
Here's a UDF that you can use to populate an array with unique random numbers:
Function GetRandomDigits(amount As Integer, maxNumber As Integer) As Variant
With CreateObject("System.Collections.ArrayList")
Do
j = WorksheetFunction.RandBetween(1, maxNumber)
If Not .Contains(j) Then .Add j
Loop Until .Count = amount
GetRandomDigits = .ToArray()
End With
End Function
And here's an example of how to use it:
Sub MM()
Dim nums As Variant
nums = GetRandomDigits(10, 100)
For Each num In nums
Debug.Print num
Next
End Sub
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...
I need to do the ‘vlookup’ function using the VBA. I need to lookup data from a access database containg 4.6 million records.
Private Sub connectDB()
Dim sqlstr As String
Dim mydata As String
Dim t, d, conn, rst, mydata
Dim arr, arr1
t = Timer
Set d = CreateObject("scripting.dictionary")
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
mydata = "mydatabase"
strconn = "Provider = Microsoft.ACE.OLEDB.16.0; Data Source = " & mydata
sqlstr = "select Tracking, MAWB from total"
rst.Open sqlstr, strconn, 3, 2
arr1 = Array("Tracking", "MAWB")
arr = rst.GetRows(-1, 1, arr1)
STOP
#Above cost 1mins
For i = 0 To UBound(arr, 2)
d(arr(0, i)) = arr(1, i)
Next
STOP
#Put data into dictionary always costs me 20 mins
The procedure above always cost me around 20 mins. And the majority of them are spent on the putting data into dictionary
Anyway to reduce the time cost?
You could reduce significantly the lookup time by implementing your own hashtable/dictionary.
Here's an example indexing a 4 millions array under 5 seconds:
Private Declare PtrSafe Function RtlComputeCrc32 Lib "ntdll.dll" ( _
ByVal start As Long, ByVal data As LongPtr, ByVal size As Long) As Long
Sub Example()
Dim data(), slots() As Long, i As Long
' generate some records '
ReDim data(0 To 1, 0 To 4000000)
For i = 0 To UBound(data, 2)
data(0, i) = CStr(i)
Next
' index all the keys from column 1 '
MapKeys slots, data, column:=0
' lookup a key in column 1 '
i = IndexOfKey(slots, data, column:=0, key:="4876")
If i >= 0 Then
Debug.Print "Found at index " & i
Else
Debug.Print "Missing"
End If
End Sub
Public Sub MapKeys(slots() As Long, data(), column As Long)
Dim bucketsCount&, key$, r&, i&, s&, h&
bucketsCount = UBound(data, 2) * 0.9 ' n * load factor '
ReDim slots(0 To UBound(data, 2) + bucketsCount)
For r = 0 To UBound(data, 2) ' each record '
key = data(column, r)
h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF ' get hash '
s = UBound(slots) - (h Mod bucketsCount) ' get slot '
Do
i = slots(s) - 1& ' get index (base 0) '
If i >= 0& Then ' if index for hash '
If data(column, i) = data(column, r) Then Exit Do ' if key present, handle next record '
Else
slots(s) = r + 1& ' add index (base 1) '
Exit Do
End If
s = i ' collision, index points to the next slot '
Loop
Next
End Sub
Public Function IndexOfKey(slots() As Long, data(), column As Long, key As String) As Long
Dim h&, s&, i&
h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF ' get hash '
s = UBound(slots) - (h Mod (UBound(slots) - UBound(data, 2))) ' get slot '
i = slots(s) - 1& ' get index (base 0) '
Do While i >= 0&
If data(column, i) = key Then Exit Do ' break if same key '
i = slots(i) - 1& ' collision, index points to the next slot '
Loop
IndexOfKey = i
End Function
Although scripting dictionary is pretty fast at performing lookups, loading one up gets progressively slower the more you put into it: when you're in the millions of items then it gets really slow to load.
So, you could maybe consider something like splitting your values across an array of dictionary objects. All other excellent suggestions aside, this would at least reduce your runtime with your current setup. The only caveat is the "keys" queried from your database would need to be unique.
Sub LookupTester()
Const NUM_VALUES As Long = 4000000# '<< size of total dataset
Const MAX_PER_DICT As Long = 400000 '<< max # of entries per dictionary
Dim numDicts As Long, i As Long, n, t, d, v, r, c As Long
Dim arrD() As Scripting.Dictionary
numDicts = Application.Ceiling(NUM_VALUES / MAX_PER_DICT, 1)
ReDim arrD(1 To numDicts)
'initialize the array of dictionaries
For n = 1 To numDicts
Set arrD(n) = New Scripting.Dictionary
Next n
t = Timer
n = 1
c = 0
Set d = arrD(n)
'Load up some dummy data...
For i = 1 To NUM_VALUES
d("Value_" & i) = i
c = c + 1
If i Mod 400000 = 0 Then Debug.Print "Store", i, Timer - t 'check progresss
If c = MAX_PER_DICT Then
n = n + 1
If i <> NUM_VALUES Then Set d = arrD(n)'<< next dict
c = 0
End If
Next i
'Done storing: 87 sec in my test
t = Timer
Randomize
'perform a million lookups
For i = 1 To 1000000#
v = "Value_" & CLng(Rnd() * NUM_VALUES)
For n = 1 To numDicts
If arrD(n).Exists(v) Then
r = arrD(n)(v) '<< lookup result
Exit For
End If
Next n
If i Mod 100000 = 0 Then Debug.Print "Query", i, Timer - t
Next i
'Done querying: ~320 sec to run the queries
End Sub
You could wrap up this type of thing into a nice class...
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
Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.
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