I'm new to Excel VBA. The project I'm working on deals with ranges of random numbers. I have five ranges and found this code which works really well for not getting any duplicates in a range:
Public Sub generateRandNum()
'Define your variabiles
lowerbound = 1
upperbound = 20000
Set randomrange = Range("A1:C5000")
randomrange.Clear
For Each rng1 In randomrange
counter = counter + 1
Next
If counter > upperbound - lowerbound + 1 Then
MsgBox ("Number of cells > number of unique random numbers")
Exit Sub
End If
For Each Rng In randomrange
randnum = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Do While Application.WorksheetFunction.CountIf(randomrange, randnum) >= 1
randnum = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Loop
Rng.Value = randnum
Next
End Sub
The next part of the project involves the excluding one number (not random) from the second set and two numbers (also not random) from the fourth set.
I've searched all over Google, looked at a number of forums, but either the code looks really long or I can't quite understand it enough to modify it for my needs.
It has to be in VBA because the number generator works off of a button click.
you can use a Dictionary object to store "forbidden" numbers for each single column
Option Explicit
Public Sub generateRandNum()
'Define your variabiles
Dim lowerbound As Long, _
upperbound As Long
lowerbound = 1
upperbound = 20 '20000
'define forbidden numbers for each single column
Dim forbiddenNumbersDict As Object
Set forbiddenNumbersDict = CreateObject("Scripting.Dictionary")
With forbiddenNumbersDict
.Add 2, Array(1, 4, 9) ' column 2 forbidden numbers
.Add 3, Array(2, 5, 7) ' column 3 forbidden numbers
'....
End With
Dim randomrange As Range
Set randomrange = Range("A1:C5")
randomrange.Clear
Dim counter As Long
counter = randomrange.Count
If counter > upperbound - lowerbound + 1 Then
MsgBox ("Number of cells > number of unique random numbers")
Exit Sub
End If
Dim rng As Range
For Each rng In randomrange
Dim rngColIndex As Long
rngColIndex = rng.Column ' locate the current column
Dim randnum As Long
randnum = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Do While Application.WorksheetFunction.CountIf(randomrange, randnum) >= 1 _
Or Not IsError(Application.Match(randnum, forbiddenNumbersDict(rngColIndex), 0)) ' added the condition to exclude forbidden numbers for the current column
randnum = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Loop
rng.Value = randnum
Next
End Sub
BTW, your algorithm is quite inefficient
Related
The following code is not working. I get a 2042 error for my VLOOKUP function, however whatever I do I cannot solve it. I have been using if ISERROR and it still does not catch it properly compromising my whole macro. If I run a local window you can see that the value to search for being stored in array "arr" if not found in the "target" range return a 2042 even for subsequent entries.
Sub test()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9))
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = "N/A"
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
SOLUTION
Sub test()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'The problem was here. "A1:T110" did not allowed to the shifting range to change. Now this code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
Declare your Target_MatchValue As Variant so no errors will be raised, instead you will have to handle what do you want to do when IsError(Target_MatchValue) (when no matches are found)
I have got a specific Range e.g B2-I2 (which can vary) that contains values e.g 1,2,4,5,34,4,23,12. The aim is to have a macro which finds the largest absolute difference in that given range when the function is executed. In the above example the largest abs. difference would be 30 (as 34-4).
It looks like you're wanting to find the largest sequential difference, if so, try this ...
Public Function GetLargestDifference(ByVal objCells As Range) As Double
Dim objCell As Range, i As Long, dblThisDiff As Double, arrValues()
' Put the (potentially) non sequential set of cells into a one dimensional array.
For Each objCell In objCells
ReDim Preserve arrValues(i)
arrValues(i) = objCell.Value
i = i + 1
Next
' Now process that array and check for the max difference.
For i = 0 To UBound(arrValues) - 1
dblThisDiff = arrValues(i) - arrValues(i + 1)
If dblThisDiff > GetLargestDifference Then GetLargestDifference = dblThisDiff
Next
End Function
... there's no error checking for non numeric values but you can add that as required.
If you need to do an absolute check then replace this line ...
dblThisDiff = arrValues(i) - arrValues(i + 1)
... with this ...
dblThisDiff = Abs(arrValues(i) - arrValues(i + 1))
try:
Option Explicit
Sub test()
Dim i As Long, y As Long, ValueArr As Long, ValueY As Long, MaxDiff As Long
Dim arr As Variant
With ThisWorkbook.Worksheets("Sheet1")
arr = Application.Transpose(.Range("B2:I2").Value)
For i = LBound(arr) To UBound(arr)
ValueArr = Abs(arr(i, 1))
For y = 2 To 9
ValueY = Abs(.Cells(2, y).Value)
If ValueArr - ValueY > MaxDiff Then
MaxDiff = ValueArr - ValueY
End If
Next y
Next i
MsgBox MaxDiff
End With
End Sub
Heylo, I have been learning Excel VBA and Macros lately for fun, but I've run into a problem with a practice exercise I'm going through... I have a function that started producing a #VALUE! error with certain selected ranges and I'm slightly confused on how to fix it. The function does different calculations based on what cell is being autofilled. The function is below:
Function CalculateStuff(myRange As Range) As Double
Application.Volatile
Dim numRows As Long
numRows = myRange.Rows.Count
Dim whatColumn As Long
whatColumn = Application.Caller.Column - myRange.Column
Dim i As Long
Dim thing As Double
Dim mainThing As Double
Select Case whatColumn
Case 0
CalculateStuff = WorksheetFunction.Sum(myRange.Columns(1))
Case 1
CalculateStuff = WorksheetFunction.SumProduct(myRange.Columns(1), myRange.Columns(2))
Case 2
CalculateStuff = WorksheetFunction.SumProduct(myRange.Columns(1), myRange.Columns(3)) / WorksheetFunction.Sum(myRange.Columns(1))
Case 3
CalculateStuff = WorksheetFunction.SumSq(myRange.Columns(4))
Case 4
For i = 1 To numRows
thing = myRange(i, 1) * WorksheetFunction.SumSq(myRange(i, 3), myRange(i, 5))
mainThing = mainThing + thing
Next i
CalculateStuff = mainThing
End Select
End Function
And then I use it in a subroutine to populate the active cell's formula and autofill to the right of the active cell. The subroutine is as follows:
Sub RunCalculateStuff()
Dim initialRange As Range
Set initialRange = Application.InputBox("Please select the cells in the first column you would like to use...", Type:=8)
Dim finalRange As Range
Dim i As Long
i = 0
For Each initialCell In initialRange
If i = 0 Then
Set finalRange = ActiveSheet.Range(initialCell, initialCell.Offset(0, 4))
i = i + 1
Else
Set finalRange = Application.Union(finalRange, ActiveSheet.Range(initialCell, initialCell.Offset(0, 4)))
i = i + 1
End If
Next
ActiveCell.Formula = "=CalculateStuff(" + finalRange.Address + ")"
ActiveCell.AutoFill Destination:=ActiveSheet.Range(ActiveCell, ActiveCell.Offset(0, 4))
End Sub
The subroutine works by letting the user select the cells in the first column they would like to use, then loops through those cells and grabs the cells up to an offset of (0, 4) away and adds that range to an overall range. This range is then fed to this function and it goes.
Heres' where the #VALUE! error comes in... It only happens when the cells that I select are not sequential... By this I mean, if I select the range AA1:AA4 with the initial get box, it works just fine. If I select the range AA1, AA2, AA3, AA4 individually, it works just fine. But if I select the range AA1, AA3, I get the #VALUE! Error. I get the feeling it has something to do with skipping rows, but I really don't understand why since I'm doing a Union into its own range. Plus, it fails when I just try to sum the first column of the range in the very first calculation, then it fails in the rest as well. Screenshots below for what I mean.
Working Range:
Broken Range:
Thank you in advance for your help! I really appreciate it.
This seemed to work for me. Posting in case you did not have any luck, or if you need inspiration. Note that I didn't do any error checking to see if all the elements of your input are Ranges.
Function CalculateStuff2(ParamArray Rngs()) As Double
Dim i As Integer
Dim col As Long
Dim tmpRng As Range
Dim tmpDbl As Double
Dim divisor As Double
Dim IsCase2 As Boolean
Dim numRows As Long, r As Long
For i = LBound(Rngs()) To UBound(Rngs())
Set tmpRng = Rngs(i)
col = Application.Caller.Column - tmpRng.Column
numRows = tmpRng.Rows.Count
Select Case col
Case 0
tmpDbl = tmpDbl + WorksheetFunction.Sum(tmpRng.Columns(1))
Case 1
tmpDbl = tmpDbl + WorksheetFunction.SumProduct(tmpRng.Columns(1), tmpRng.Columns(2))
Case 2
IsCase2 = True
tmpDbl = tmpDbl + WorksheetFunction.SumProduct(tmpRng.Columns(1), tmpRng.Columns(3))
divisor = divisor + WorksheetFunction.Sum(tmpRng.Columns(1))
Case 3
tmpDbl = tmpDbl + WorksheetFunction.SumSq(tmpRng.Columns(4))
Case 4
For r = 1 To numRows
tmpDbl = tmpDbl + tmpRng(r, 1) * WorksheetFunction.SumSq(tmpRng(r, 3), tmpRng(r, 5))
Next r
End Select
Next i
If IsCase2 Then
CalculateStuff2 = tmpDbl / divisor
Else
CalculateStuff2 = tmpDbl
End If
End Function
I would like to implement a custom function into Excel which returns the minimum of a trimmed data sample.
Two inputs:
Data
Percentage, which states how many data points from the original data sample should be excluded
My first draft (seen below) misses two features right now:
When I use the function and select a whole column (e. g. =TrimMIN(A:A)) it takes takes a long time
I need to sort the input Range 'data' before trimming it but the line 'data.Cells.Sort' is not working
Looking forward to get get some ideas on those two issues.
My code:
Function TrimMIN(data As Range, percentage As Double) As Double
Dim dataNew As Range
Dim dataNewS As Variant
Dim diff, counter, upper, lower, countDataNew As Double
counter = 0
'data.Cells.Sort
diff = Round(data.Count * percentage / 2, [0])
Debug.Print "diff= " & diff
upper = data.Count - diff
lower = diff
countDataNew = data.Count - diff - diff
'Application.Min(data)
'Debug.Print "upper= " & upper
'Debug.Print "lower= " & lower
'Debug.Print "data.count= " & data.count
'Debug.Print "countDataNew= " & countDataNew
Dim cel As Range
For Each cel In data.Cells
counter = counter + 1
'Debug.Print "counter= " & counter
Debug.Print "celValue= " & cel.Value
If counter > lower And counter <= upper Then
'Debug.Print "counter in range, counter is " & counter
If Not dataNew Is Nothing Then
' Add the 2nd, 3rd, 4th etc cell to our new range, rng2
' this is the most common outcome so place it first in the IF test (faster coding)
Set dataNew = Union(dataNew, cel)
Else
' the first valid cell becomes rng2
Set dataNew = cel
End If
End If
Next cel
'Debug.Print "dataNew.count " & dataNew.count
TrimMIN = Application.Min(dataNew)
End Function
This is a working function.
Ideally it is up to you to place an appropriate range as argument to the funtion...
Public Function TrimMin(data As Range, percentage As Double) As Double
Dim usedData As Variant
'avoid calculating entire columns or rows
usedData = Intersect(data, data.Parent.UsedRange).Value
Dim x As Long, y As Long
x = UBound(usedData) - LBound(usedData) + 1
y = UBound(usedData, 2) - LBound(usedData, 2) + 1
Dim arr() As Variant
ReDim arr(1 To x * y)
Dim i As Long, j As Long, counter As Long
counter = 1
For i = 1 To x
For j = 1 To y
If Application.WorksheetFunction.IsNumber(usedData(i, j)) Then
arr(counter) = usedData(i, j)
counter = counter + 1
End If
Next j
Next i
ReDim Preserve arr(1 To counter - 1)
Dim diff As Long
diff = Round((counter - 1) * percentage / 2, 0) + 1
'use the worksheet function to obtain the appropriate small value
TrimMin = Application.WorksheetFunction.Small(usedData, diff)
End Function
Write a subroutine in VBA to generate a winning lotto ticket consisting of 6 integer numbers randomly drawn from 1 to 40.
In order to have a small simulation animation, range("A1:E8") should contain the numbers 1 to 40 and the subroutine should then cycle through these numbers using a colored cell and then momentarily pause 2 seconds on a selected winning number. The list of winning numbers drawn should then be printed in the range("G2:G7"). In case a number drawn has already been drawn previously in the list, then a new number should be redrawn.
I have only been able to do as follows.
Option Explicit
Sub test1()
Sheet1.Cells.Clear
Dim i As Integer
For i = 1 To 40
Cells(i, 1) = i
Next
End Sub
'-----------------------------
Option Explicit
Option Base 1
Function arraydemo(r As Range)
Dim cell As Range, i As Integer, x(40, 1) As Double
i = 1
For Each cell In r
x(i, 1) = cell.Value
i = i + 1
Next cell
arraydemo = x
End Function
Sub test3()
Dim x() As String
chose = Int(Rnd * UBound(x))
End Sub
I got stuck elsewhere, the sub test3(), does not seem appropriate here. I need some suggestions. Also, I appologise for my poor formatting, I am new to this.
Populating your range like this:
range("A1:E8") should contain the numbers 1 to 40
Sheet1.Cells.Clear
Dim i As Integer
Dim rng as Range
Set rng = Range("A1:E8")
For i = 1 To 40
rng
Next
generate a winning lotto ticket consisting of 6 integer numbers randomly drawn from 1 to 40
Using a dictionary object to keep track of which items have been picked (and prevent duplicate) in a While loop (until there are 6 numbers chosen):
Dim picked as Object
Set picked = CreateObject("Scripting.Dictionary")
'Select six random numbers:
i = 1
While picked.Count < 6
num = Application.WorksheetFunction.RandBetween(1, 40)
If Not picked.Exists(num) Then
picked.Add num, i
i = i + 1
End If
Wend
Using the Application.Wait method to do the "pause", you can set up a procedure like so:
'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
For Each val In picked.Keys()
rng.Cells(picked(val)).Interior.ColorIndex = 39 'Modify as needed
Application.Wait Now + TimeValue("00:00:02")
rng.Cells(picked(val)).Interior.ColorIndex = xlNone
Next
The list of winning numbers drawn should then be printed in the range("G2:G7").
Print the keys from the picked dictionary:
Range("G2:G7").Value = Application.Transpose(picked.Keys())
Putting it all together:
Sub Lotto()
Dim i As Integer, num As Integer
Dim rng As Range
Dim picked As Object 'Scripting.Dictionary
Dim val As Variant
'Populate the sheet with values 1:40 in range A1:E8
Set rng = Range("A1:E8")
For i = 1 To 40
rng.Cells(i) = i
Next
'Store which numbers have been already chosen
Set picked = CreateObject("Scripting.Dictionary")
'Select six random numbers:
i = 1
While picked.Count < 6
num = Application.WorksheetFunction.RandBetween(1, 40)
If Not picked.Exists(num) Then
picked.Add num, i
i = i + 1
End If
Wend
'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
For Each val In picked.Keys()
rng.Cells(val).Interior.ColorIndex = 39 'Modify as needed
Application.Wait Now + TimeValue("00:00:02")
rng.Cells(val).Interior.ColorIndex = xlNone
Next
'Display the winning series of numbers in G2:G7
Range("G2:G7").Value = Application.Transpose(picked.Keys())
End Sub
NOTE This absolutely will not work on Excel for Mac, you would need to use a Collection instead of a Dictionary, as the Scripting.Runtime library is not available on Mac OS.
In addition to the excellent answer given by member David Zemens, following is the universal function written in "pure" Excel VBA, which does not contain any Excel Worksheet Functions, neither Dictionary Object (re: CreateObject("Scripting.Dictionary").
Option Explicit
'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbers(LB As Integer, UB As Integer, N As Integer) As Variant
Dim I As Integer
Dim arrRandom() As Integer
Dim colRandom As New Collection
Dim colItem As Variant
Dim tempInt As Integer
Dim tempExists As Boolean
'check that ArraySize is less that the range of the integers
If (UB - LB + 1 >= N) Then
While colRandom.Count < N
Randomize
' get random number in interval
tempInt = Int((UB - LB + 1) * Rnd + LB)
'check if number exists in collection
tempExists = False
For Each colItem In colRandom
If (tempInt = colItem) Then
tempExists = True
Exit For
End If
Next colItem
' add to collection if not exists
If Not tempExists Then
colRandom.Add tempInt
End If
Wend
'convert collection to array
ReDim arrRandom(N - 1)
For I = 0 To N - 1
arrRandom(I) = colRandom(I + 1)
Next I
'return array of random numbers
RandomNumbers = arrRandom
Else
RandomNumbers = Nothing
End If
End Function
'get 5 Random numbers in the ranger 1...10 and populate Worksheet
Sub GetRandomArray()
Dim arr() As Integer
'get array of 5 Random numbers in the ranger 1...10
arr = RandomNumbers(1, 10, 5)
'populate Worksheet Range with 5 random numbers from array
If (IsArray(arr)) Then
Range("A1:A5").Value = Application.Transpose(arr)
End If
End Sub
The function
Function RandomNumbers(LB As Integer, UB As Integer, N As Integer)
returns array of N random numbers in the range LB...UB inclusively without repetition.
Sample Sub GetRandomArray() demonstrates how to get 5 random numbers in the range 1...10 and populate the Worksheet Range: it could be customized for any particular requirements (e.g. 8 from 1...40 in PO requirements).
APPENDIX A (Courtesy of David Ziemens)
Alternatively, you can do similar without relying on Collection object at all. Build a delimited string, and then use the Split function to cast the string to an array, and return that to the calling procedure.
This actually returns the numbers as String, but that shouldn't matter for this particular use-case, and if it does, can easily be modified.
Option Explicit
Sub foo()
Dim arr As Variant
arr = RandomNumbersNoCollection(1, 40, 6)
End Sub
'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbersNoCollection(LB As Integer, UB As Integer, N As Integer)
Dim I As Integer
Dim numbers As String ' delimited string
Dim tempInt As Integer
Const dlmt As String = "|"
'check that ArraySize is less that the range of the integers
If (UB - LB + 1 >= N) Then
' get random number in interval
Do
Randomize
tempInt = Int((UB - LB + 1) * Rnd + LB)
If Len(numbers) = 0 Then
numbers = tempInt & dlmt
ElseIf InStr(1, numbers, tempInt & dlmt) = 0 Then
numbers = numbers & tempInt & dlmt
End If
Loop Until UBound(Split(numbers, dlmt)) = 6
numbers = Left(numbers, Len(numbers) - 1)
End If
RandomNumbersNoCollection = Split(numbers, dlmt)
End Function