Hi I'm trying to generate n random numbers in Vba code so that their sum must be different in each time:
one time sum must be 1000
one time sum must be 1500...and so on
the sum in the code is called (items)
the problem is the array I didn't want to generate the random numbers for fixed rows, I need to generate randomly one time 10 rows for one columns..one time 15 rows for 1 columns...
How can I fix that?
Sub randomality()
Dim ary(1 To 10) As Double, zum As Double
Dim i As Long
Randomize
zum = 0
Dim destination_order_unit As String
Dim items As Variant
Number_required = Range("K2").Value
destination_order_unit = Range("L5").Value
Range(destination_order_unit).Select
items = InputBox("All units ")
Range("J2").Value = items
For i = 1 To 10
ary(i) = Rnd
zum = zum + ary(i)
Next i
For i = 1 To 10
ary(i) = ary(i) / zum
Next i
With Application.WorksheetFunction
For i = 1 To 10
Cells(i, "D").Value = Application.WorksheetFunction.RoundUp(items * ary(i), 0)
Next i
Cells(10, "D").Value = items - .Sum(Range("D1:D9"))
End With
End Sub
I think your question is more along the lines of how to insert an array that goes vertically? The random number issue is throwing me off and I'm having a hard time following, but this is how you could create a set of 10 random numbers that sum to 20. You could re-engineer this if you're trying to just ensure they are not the same at the end of the loop by saying <> to.
Sub BuildRandoms()
Const minNumber As Long = 0
Const MaxNumber As Long = 5
Const finalSum As Long = 20
Dim ary(1 To 10) As Long, i As Long
Do
For i = LBound(ary) To UBound(ary)
ary(i) = Application.WorksheetFunction.RandBetween(minNumber, MaxNumber)
Next i
Loop Until Application.WorksheetFunction.Sum(ary) = finalSum
'resized the range you're trying to paste values
Range("D10").Resize(UBound(ary), 1).Value = Application.WorksheetFunction.Transpose(ary)
End Sub
Related
good evening, im quite a long lurker here but i have ran into an issue i cant seem to find a solution for. i have no idea if i post this correctly as i dont have any base code to provide because im not sure if it is possible at all in VBA.
i have a list with values that is variable in size and the induvidual values range from 1 to 33. (this is based on pallet amounts in trucks) what i would like to be able to do is select that range and have a vba code sort out the best way to sum up my values to 33 (But never ever over 33!) and create an array with the values and move on to the next "set" and put the next values that add to 33 in a new array. i know how to do it chronically (thanks to another user here on stackoverflow) but that would mean that it isnt the most efficient option.
lets say i have a list of 5 different values:
10
15
8
22
19
this would create the following "sets":
25
30
19
but if the order of the 5 values would change to:
19
22
15
10
8
it would create the following sets:
19
22
15
18
now i have found a way to define a variable to the optimal number of trucks the code should create, but with the second list it would result in an error if the code i have now goes through that list chronically.
so to summarize, is it possible to create a code that would look at a selection of values and decide what the best most efficient way is of combining values the closest to 33.
ill provide the code i have now, please note it is not at all finished yet and very basic as its just the start of my project and pretty much the core feature of what i want to achieve. if i need to provide more info or details please let me know
thanks in advance. and many thanks to a huge group of people here who unbeknownst to themselves have already helped me save hours upon hours of work by providing their solutions to problems i had but didnt need to ask
here is my code:
Sub test()
Dim ref, b As Range
Dim volume, i As Integer
Dim test1(), check, total As Double
Dim c As Long
Set ref = Selection
volume = ref.Cells.Count
c = ref.Column
ReDim test1(1 To volume)
'this creates a total of all the values i select
For Each b In ref
total = total + b
Next b
'this determines when to round up or down
check = total / 33 - Application.WorksheetFunction.RoundDown(total / 33, 0)
If check < 0.6 Then
total = Application.WorksheetFunction.RoundDown(total / 33, 0)
Else
total = Application.WorksheetFunction.RoundUp(total / 33, 0)
End If
'this creates an array with all the values
i = 1
Do Until i = volume + 1
test1(i) = Cells(i, c).Value
i = i + 1
Loop
'this is just a way for me to check and verify my current part of the code
MsgBox (Round(test1(8), 2))
MsgBox (total)
End Sub
You can change the cell result location as per your wish. I am showing the result in the immediate window.
Sub test()
Dim CellsCount As Integer
CellsCount = Selection.Cells.Count
Dim i, j As Long
Dim x, y As Long
Dim SumLoop As Long
SumLoop = 0
x = 1
y = 1
For i = x To CellsCount
Do
For j = y To CellsCount
SumLoop = SumLoop + Selection.Cells(j).Value
If SumLoop < 33 Then
Debug.Print SumLoop
y = j + 1
If y = CellsCount + 1 Then Exit Sub
Else
SumLoop = 0
x = j
y = j
Exit For
End If
Next
Loop While SumLoop < 33
Next
End Sub
This is a straight brute force, checking every single combination, if your set gets too big this will slow way down but it was <1 second on a set of 1,000.
I loaded values into Column A. Outputs the lowest amount of trucks you need.
You can probably reduce the amount of variables by using a type or class but wanted to keep it relatively simple.
Dim i As Long
Dim lr As Long
Dim limit As Long
Dim count As Long
Dim sets As Long
Dim best As Long
Dim start As Long
Dim addset As Boolean
Dim loopcounter As Long
limit = 33
With Sheets("Sheet1")
lr = .Cells(.Rows.count, 1).End(xlUp).Row
Dim arr() As Long
ReDim arr(0 To lr - 2)
For i = 2 To lr
arr(i - 2) = .Cells(i, 1).Value 'Load array
Next i
start = 0
i = start
Do
If count + arr(i) <= limit Then
count = count + arr(i)
addset = False 'Just for tracking the final set
Else
addset = True
sets = sets + 1
count = arr(i)
End If
i = i + 1
If i > UBound(arr) Then
i = 0 'reset index
End If
loopcounter = loopcounter + 1 'tracking items in set
If loopcounter > UBound(arr) Then
If addset = False Then
sets = sets + 1 'adding final set if not already added
End If
Debug.Print start, sets
If best > sets Or best = 0 Then
best = sets 'Get the lowest value
End If
'resetting values
loopcounter = 0
sets = 0
start = start + 1
i = start
If start > UBound(arr) Then
Exit Do
End If
End If
Loop
End With
Debug.Print best
I have a spreadsheet that lists all permutations of 5 columns of data into a single column of text (Column X aka 24) and my goal is to extract only actual words from that list into its own column (Column Y aka 25). The first part is not performed with VBA and happens almost instantaneously, but the spell check + extracting the actual words takes over an hour to complete (I've had to stop it it after 10 minutes and not even 10% of the way through). Is there a better way to do this?
My lists start on row 6 (n = 6) and Range("V3") is just the number of permutations (in this case, 83,521).
Sub Permute_and_Extract()
n = 6
Range("X7:X1000000").ClearContents
Range("Y6:Y1000000").ClearContents
Max = Range("V3") + 5
Range("X6").Select
Selection.AutoFill Destination:=Range("X6:X" & Max)
For i = 6 To Max
x = Application.CheckSpelling(Cells(i, 24).Text)
If x = True Then
Cells(n, 25) = Cells(i, 24)
n = n + 1
End If
Next i
End Sub
Following from the comments above:
Sub Permute_and_Extract()
Const RNG As String = "F1:F10000"
Dim wlist As Object, t, c As Range, i As Long, arr, res
Dim rngTest As Range
Set rngTest = ActiveSheet.Range(RNG)
t = Timer
Set wlist = WordsList("C:\Temp\words.txt", 5)
Debug.Print "loaded list", Timer - t
Debug.Print wlist.Count, "words"
'using an array approach...
t = Timer
arr = rngTest.Value
For i = 1 To UBound(arr, 1)
res = wlist.exists(arr(i, 1))
Next i
Debug.Print "Array check", Timer - t
'going cell-by-cell...
t = Timer
For Each c In rngTest.Cells
res = wlist.exists(c.Value)
Next c
Debug.Print "Cell by cell", Timer - t
End Sub
'return a dictionary of words of length `wordLen` from file at `fPath`
Function WordsList(fPath As String, wordLen As Long) As Object
Dim dict As Object, s As String
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare 'case-insensitive !!!
With CreateObject("scripting.filesystemobject").opentextfile(fPath)
Do While Not .AtEndOfStream
s = .readline()
If Len(s) = wordLen Then dict.Add s, True
Loop
.Close
End With
Set WordsList = dict
End Function
Output:
loaded list 0.359375
8938 words
Array check 0.019
Cell by cell 0.030
For the first 15 ranks, I want to manually enter the values in B2:P11. For ranks 16 to 30, I want to randomize these values using an Excel VBA button, with the following code:
Sub rand_group()
Dim i As Long
Dim j As Long
Dim myFlag(1 To num_man)
Dim s_group As Worksheet
Set s_group = Worksheets("group")
'óêêîånóÒÇèâä˙âª
Randomize
s_group.Cells.Clear
s_group.Range("A1") = "group_id"
For i = 1 To num_group
s_group.Cells(i + 1, 1) = i
Next i
For i = 1 To num_man
s_group.Cells(1, i + 1) = "m_rank" & i
Next i
For i = 1 To num_group
For j = 16 To num_man
myFlag(j) = False
Next j
For j = 16 To num_man
Do
'óêêî=Int((ç≈ëÂíl - ç≈è¨íl +1 ) * Rnd + ç≈è¨íl)
myNum = Int((num_man - 1 + 1) * Rnd + 1)
Loop Until myFlag(myNum) = False
s_group.Cells(i + 1, j + 1).Value = myNum
myFlag(myNum) = True
Next j
Next i
End Sub
However, these random values should neglect the manually entered values in B2:P11
How can I change the code to fix this?
Screenshot of the excel file is displayed below:
I want to manually fill values from B2 to P11
Thank you in advance for your response!
Michiel
To fill in the random section of the grid, the myFlag array is not needed. Just use the cell coordinates to set the random values. Also remove the Clear call since that clears the entire sheet.
To prevent duplicate numbers in a row, use the excel CountIf function in a loop until a unique random number is found.
Here is the updated code. It can be run multiple times without affecting the manual data.
Sub DoRand()
Dim i As Long
Dim j As Long
Dim s_group As Worksheet
Set s_group = Worksheets("group")
num_group = 10
num_man = 30
Randomize
's_group.Cells.Clear ' clear sheet
' build table
For i = 1 To num_group ' group id
s_group.Cells(i + 1, 1) = i
Next i
For i = 1 To num_man ' column names
s_group.Cells(1, i + 1) = "m_rank" & i
Next i
' fill in random numbers
For i = 1 To num_group 'row
For j = 16 To num_man 'column
Do While True
n = Int((num_man) * Rnd + 1) ' get random number
cnt = Application.WorksheetFunction.CountIf(Range(s_group.Cells(i + 1, 2), s_group.Cells(i + 1, j)), "=" & n) ' check if number in row
s_group.Cells(i + 1, j + 1).Value = n ' set cell value
If cnt = 0 Then Exit Do ' if unique in row, go to next cell
Loop ' not unique, try new random value
Next
Next
End Sub
I want my code to pick a random number between 0 and 99, and then do it again 99 more times without picking a duplicate. I know how I'd do this in a very inefficient way (pick a random number and then check it against all numbers already picked, repicking if it is a duplicate).
I am sure that there is a better way, I just am not sure what to call the correct structure and thus I'm having a hard time getting the google results I need to figure this out.
What I think I need to do:
Build a "list" of 100 items, numbers 0 - 99.
Pick 1 item at random from that list, which will remove it from the list.
Pick from the entire list again, this time the list is 99 items in size.
Repeat until the list is empty
What is this called and what are the key concepts I need to understand?
See 2-Dimensional array with different data type columns Generate 0 to 99 then randomise the table.
Arrays are all the same type.
Recordsets are tables. This reads a text file and puts a random number as a double and a string into each record.
Randomize
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "RandomNumber", 4
.Fields.Append "Txt", 201, 5000
.Open
Do Until Inp.AtEndOfStream
.AddNew
.Fields("RandomNumber").value = Rnd() * 10000
.Fields("Txt").value = Inp.readline
.UpDate
Loop
.Sort = "RandomNumber"
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
Answering my own question based on information I learned from the comments.
Here is how I did it using Collections:
Sub collections()
Randomize
Dim x As Byte
Dim coll As New Collection
Dim pick As Integer
Dim i As Byte: i = 1
For x = 0 To 99
coll.Add x
Next
Do While coll.Count <> 0
pick = Int((coll.Count - 1 + 1) * Rnd + 1)
'Cells(i, 1).Value = coll.Item(pick)
coll.Remove (pick)
i = i + 1
Loop
end sub
A little long winded, but I wanted to check to be sure it was working right (hence write to the activesheet and i as a counter).
Here is how I did it using a Dictionary:
Sub dictionary()
Randomize
Dim dict As New Scripting.dictionary
Dim x As Byte
Dim pick As Integer
Dim i As Byte: i = 1
For x = 0 To 99
Do
pick = Int((99 - 0 + 1) * Rnd + 0)
Loop Until Not dict.Exists(pick)
dict.Add pick, 0
'Cells(i, 4).Value = pick
i = i + 1
Next
End Sub
And when I compared the two ways of doing it, the collections sub was always faster by ~ a factor of 10.
Dim StartTime As Double
Dim ElapsedTime As Double
Dim TotalTime As Double
Dim x As Byte
For x = 1 To 100
StartTime = Timer
Call collections
ElapsedTime = Timer - StartTime
TotalTime = TotalTime + ElapsedTime
Next
Debug.Print TotalTime & " Collections"
TotalTime = 0
For x = 1 To 100
StartTime = Timer
Call dictionary
ElapsedTime = Timer - StartTime
TotalTime = TotalTime + ElapsedTime
Next
Debug.Print TotalTime & " Dictionary"
I have a dynamic population of tasks that I receive monthly, I want to assign these tasks to 6 groups for them to assess in an evenly distributed fashion. Each task has a ranking/priority, so if a group receives the number 1 task, I don't want to also give that same group the top 100 priorities. I want to apply a snaking/zigzag distribution.
This led me down a path to using the formula =MIN(MOD(ROW()-2,12),MOD(-ROW()+1,12)). I get the distribution I'm looking for, although at this stage I don't know how to account for any criteria that I need to add into my logic.
In the above image I am trying to take the groups in column F and apply them to Column D. Column E shows the example of the =MOD() formula and I could just use a lookup to replace the Mod values of 0-5 with my groups 1-6.
Where I hit a roadblock is in row 21, which is where I want to account for some criteria, or exceptions. I added a binary column A for visualization, but essentially, I want to say where column C (task location) = Loc4 to never assign a task to Group 4. In the instance where I don't want a task to be assigned to Group 4 at Loc 4, I then hope to skip Group 4 for a single assignment until it can be applied to the next possible ranked task. The simple solution is to remove all these occurrences at the end, but it really skews the even distribution I'm going for.
I tried to apply solver to this assignment, looking for the lowest std deviation, but I have too many data points.
This has led me to another post using some vba logic, which I really like the concept, but I cannot figure out how to modify it to account for some exceptions. enter link description here
Ideally I would love to use this concept of creating a single array of my groups, applying each group to a task as long as the criteria is met in this short list of task, write the groups into the list, reset and move down to the next subset of tasks. So, each time I select the next 6 tasks, they are assigned to one of my 6 groups, which will keep the distribution that I'm hoping for.
Here is the code from the user K.Davis post which I was trying to apply:
Sub assignEmployeeTasks()
Dim ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets(1)
Dim employeeList() As Variant
With ws
For i = 2 To lastRow(ws, 2)
If (Not employeeList) = -1 Then
'rebuild employeelist / array uninitialized
employeeList = buildOneDimArr(ws, "F", 2, lastRow(ws, "F"))
End If
.Cells(i, 4) = randomEmployee(employeeList)
Next
End With
End Sub
These are the "support" functions that allow your program to do it's job:
Function randomEmployee(ByRef employeeList As Variant) As String
'Random # that will determine the employee chosen
Dim Lotto As Long
Lotto = randomNumber(LBound(employeeList), UBound(employeeList))
randomEmployee = employeeList(Lotto)
'Remove the employee from the original array before returning it to the sub
Dim retArr() As Variant, i&, x&, numRem&
numRem = UBound(employeeList) - 1
If numRem = -1 Then 'array is empty
Erase employeeList
Exit Function
End If
ReDim retArr(numRem)
For i = 0 To UBound(employeeList)
If i <> Lotto Then
retArr(x) = employeeList(i)
x = x + 1
End If
Next i
Erase employeeList
employeeList = retArr
End Function
' This will take your column of employees and place them in a 1-D array
Function buildOneDimArr(ByVal ws As Worksheet, ByVal Col As Variant, _
ByVal rowStart As Long, ByVal rowEnd As Long) As Variant()
Dim numElements As Long, i As Long, x As Long, retArr()
numElements = rowEnd - rowStart
ReDim retArr(numElements)
For i = rowStart To rowEnd
retArr(x) = ws.Cells(i, Col)
x = x + 1
Next i
buildOneDimArr = retArr
End Function
' This outputs a random number so you can randomly assign your employee
Function randomNumber(ByVal lngMin&, ByVal lngMax&) As Long
'Courtesy of https://stackoverflow.com/a/22628599/5781745
Randomize
randomNumber = Int((lngMax - lngMin + 1) * Rnd + lngMin)
End Function
' This gets the last row of any column you specify in the arguments
Function lastRow(ws As Worksheet, Col As Variant) As Long
lastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
End Function
Any help would be much appreciated! I'm up for any path that gets closer to my desired solution, formulas or vba. Please let me know if you have any questions.
Thanks!
This program works on a block of tasks at a time where the block size is a multiple of the group count. I have SIZE=2 to give a block size of 12 as this gives more opportunity to resolve conflicts than 6 would. It works by initially assigning the tasks to a zigzap pattern and then validates this against the rules you define. These are in the module validLocn(). If the validation is OK the process moves down the sheet to the next block. If the validation fails the plan is shuffled by swapping 2 element randomly chosen and validation retried. This continues up the maximum number set by MAXTRY. If still not resolved the user can chose to retry again, ignore and move on or abort the process. I have tested it with 150,000 records and it took less than a minute, but my test data may not represent your real data. The results in a pivot table on cols B,C,D show even distribution and no tasks for Grp4 at Locn4.
Count of Task
Row Loc1 Loc2 Loc3 Loc4 Loc5 Loc6 Gand Total
Gp1 4013 3975 3926 5082 3986 4018 25000
Gp2 4021 3992 4077 4928 3975 4007 25000
Gp3 3976 3952 4027 5023 4049 3973 25000
Gp4 5050 4915 4936 5035 5064 25000
Gp5 4072 3996 4034 4890 3969 4039 25000
Gp6 3964 4087 3986 5018 3996 3949 25000
Grand 25096 24917 24986 24941 25010 25050 150000
Hope that helps.
Option Explicit
Sub assignEmployeeTasks()
Dim ws As Worksheet, t0 As Single, t1 As Single
Set ws = ThisWorkbook.Sheets("Sheet1")
t0 = Timer
Const COL_GROUP = "F"
Const COL_LOCN = "C"
Const SIZE As Integer = 2 ' plan size = 2 * group count
Const MAXTRY = 50 ' no of tries to validate
Dim bOK As Boolean
Dim grp As Variant, iBlockStart As Long, i As Integer, r As Integer, step As Integer
'initialize grps and location
Dim countGrp As Integer, lastLocn As Long
lastLocn = ws.Range(COL_LOCN & Rows.Count).End(xlUp).Row
countGrp = ws.Range(COL_GROUP & Rows.Count).End(xlUp).Row - 1
grp = ws.Range(COL_GROUP & "2").Resize(countGrp, 1).Value
Dim plan() As String
ReDim plan(countGrp * SIZE, 2)
Dim itry As Integer, res
iBlockStart = 1
Do While iBlockStart < lastLocn
' initialize plan
Call zigzag(plan, grp)
For i = 1 To UBound(plan)
plan(i, 1) = ws.Range("C" & iBlockStart + i).Value
Next
' save 1st attempt
For i = 1 To UBound(plan)
ws.Range("D" & iBlockStart + i).Value = plan(i, 2)
Next
' validate
bOK = validLocn(plan, 0)
retry:
' retry to validate
itry = 0
While bOK = False And itry < MAXTRY
Call shuffle(plan, 1)
bOK = validLocn(plan, itry)
itry = itry + 1
Wend
' write new plan to sheet
For i = 1 To UBound(plan)
ws.Range("D" & iBlockStart + i).Value = plan(i, 2)
Next
' check rule again
If itry = MAXTRY Then
ws.Range(COL_LOCN & iBlockStart).Select
res = MsgBox("Failed to vaidate after " & MAXTRY & " attempts", vbAbortRetryIgnore, iBlockStart)
If res = vbRetry Then GoTo retry
If res = vbAbort Then Exit Sub
End If
iBlockStart = iBlockStart + UBound(plan)
Loop
t1 = Timer
MsgBox "Assigned " & lastLocn - 1 & " tasks in " & Int(t1 - t0) & " secs"
End Sub
' valid plan against rules
Function validLocn(plan As Variant, itry) As Boolean
Dim sLocn As String, sGrp As String, i As Integer
validLocn = True
For i = 1 To UBound(plan)
sLocn = plan(i, 1)
sGrp = plan(i, 2)
' rule 1
If sGrp = "Gp4" And sLocn = "Loc4" Then
validLocn = False
'Debug.Print itry, i, "Fail Rule 1", sGrp, sLocn
Else
'Debug.Print itry, i, "Pass Rule 1", sGrp, sLocn
End If
Next
End Function
' populate plan groups
Sub zigzag(plan As Variant, grp As Variant)
Dim i As Integer, r As Integer, step As Integer
r = 1: step = 1
For i = 1 To UBound(plan)
plan(i, 2) = grp(r, 1)
r = r + step
If r > UBound(grp) Then
r = UBound(grp)
step = -1
ElseIf r < 1 Then
r = 1
step = 1
End If
Next
End Sub
' shuffle plan
Sub shuffle(plan As Variant, i As Integer)
Dim tmp As String, n As Integer, j As Integer, k As Integer
For n = 1 To i
' random choose elements to shuffle
retry:
k = Int(1 + Rnd() * UBound(plan))
j = Int(1 + Rnd() * UBound(plan))
If k = j Then GoTo retry
tmp = plan(k, 2)
plan(k, 2) = plan(j, 2)
plan(j, 2) = tmp
Next
End Sub
' generate test data
Sub testdata()
Dim ws As Worksheet, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
For i = 2 To 150001
ws.Cells(i, 2) = i - 1
ws.Cells(i, 3) = "Loc" & 1 + Int(Rnd() * 6)
Next
End Sub