Excel VBA Spellcheck Way Too Slow - excel

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

Related

How to turn general data written as fractions into 3 place decimal numbers. Replace " 0." with "."

I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))

How to find a value in another sheet and get min and max values from adjustment columns

I am new to VBA macro and need some experts help on meeting the below requirement.
I got a workbook containing 2 sheets called 'Data' and 'Stats'.
'Data' contains the values as below
'Stats' contains the values as below
On click on the button, I would like to do the below
Get the values in column A in 'Stats' sheet
Find all the matching rows in 'Data' Sheet
Find the smallest start time and put that in 'Stats' sheet against the stage value
Find the biggest end time and that in 'Stats' sheet against the stage value
Final output would be like below
Note: I do not have the MINIFS or MAXIFS in my installation.
Incase you dont have MINIFS and MAXIFS you can use array formulas like so:
={MIN(IF(Stats!A1=Data!$A$1:$A$1000,Data!$C$1:$C$1000))}
and
={MAX(IF(Stats!A1=Data!$A$1:$A$1000,Data!$B$1:$B$1000))}
The {} indicates, that this is a Array-Formula. Enter with Ctrl + Shift + Enter
No VBA needed.
Just use in your Stats worksheet the following formula for Start:
=MINIFS(Data!A:A,Data!C:C,Stats!A:A)
and the following for End:
=MAXIFS(Data!B:B,Data!C:C,Stats!A:A)
Please, the VBA solution, too. It will be very fast, using arrays, processing everything in memory and dropping the result at once:
Sub BringStats()
Dim shD As Worksheet, shS As Worksheet, lastRD As Long, lastRS As Long
Dim arrD, arrS, i As Long, k As Long, dict As Object, El As Variant
Set shD = Worksheets("Data")
Set shS = Worksheets("Stats")
lastRD = shD.Range("A" & rows.count).End(xlUp).row
lastRS = shS.Range("A" & rows.count).End(xlUp).row
arrD = shD.Range("A2:C" & lastRD).Value
arrS = shS.Range("A2:C" & lastRS).Value
Set dict = CreateObject("Scripting.dictionary")
'load the dictionary with unique keys and all corresponding date in a string, as item
For i = 1 To UBound(arrD)
If Not dict.Exists(arrD(i, 3)) Then
dict.Add arrD(i, 3), CDate(arrD(i, 1)) & ";" & CDate(arrD(i, 2))
Else
dict(arrD(i, 3)) = dict(arrD(i, 3)) & "|" & CDate(arrD(i, 1)) & ";" & CDate(arrD(i, 2))
End If
Next
Dim arr As Variant, minTime As Date, minPos As Long
For i = 1 To UBound(arrS)
If dict.Exists(arrS(i, 1)) Then
arr = Split(dict(arrS(i, 1)), "|") 'extract each pair of time stamps
If UBound(arr) > 0 Then
For Each El In arr 'extract the element containing minimum time
If minTime = 0 Then
minTime = TimeValue(Split(El, ";")(0)): minPos = k
Else
If TimeValue(Split(El, ";")(0)) < minTime Then minTime = TimeValue(Split(El, ";")(0)): minPos = k
End If
k = k + 1
Next
arrS(i, 2) = Split(arr(minPos), ";")(0): arrS(i, 3) = Split(arr(minPos), ";")(1) 'load the array with the minimum time correspondent values
Else
arrS(i, 2) = Split(dict(arrS(i, 1)), ";")(0): arrS(i, 3) = Split(dict(arrS(i, 1)), ";")(1)'loading the array in case of only one occurrence
End If
End If
minPos = 0: minTime = 0: k = 0 'reinitialize the used variables
Next i
'drop the processed array at once
shS.Range("A2").Resize(UBound(arrS), UBound(arrS, 2)).Value = arrS
End Sub
There can be a lot of the same 'stage' occurrences...

Select random item from 1d array no repeat

I am trying to select random item from 1d array using this code
Sub Select_Random_Item_From_1D_Array()
Dim arr(), x As Long
arr = Array("Good", "Very Good", "Excellent")
Randomize
x = Int((UBound(arr) + 1) * Rnd + 1)
Debug.Print arr(x - 1)
End Sub
How can I be able to prevent a repetition? I mean I need to select all the items randomly with no repetition. And if all the items are selected then to reset the process. Simply I need to select all the items randomly
This is a simple way to return a random permutation of an array that takes exactly n steps, where n is the number of entries in the array.
Dim arr(), x As Long, r As Long
arr = Array("Good", "Very Good", "Excellent")
x = UBound(arr)
While x >= 0
r = Int(Rnd * x)
Debug.Print arr(r)
arr(r) = arr(x)
x = x - 1
Wend
Pick r at random from (0,..,x) and print out arr(r). Then replace the entry at r with the entry at x, and choose again, but this time from (0,..,x-1), and repeat until x=0.
A fuller version that lets you read one entry at a time is here:
Place this in a module:
Public rarr(), ctr As Integer, arr()
Sub init()
With Cells
.Clear
.ColumnWidth = 10
End With
Dim x As Long, r As Long
arr = Array("Very Poor", "Poor", "Average", "Good", "Very Good", "Excellent")
x = UBound(arr)
ReDim rarr(0 To x)
Randomize
While x >= 0
r = Int(Rnd * x)
rarr(x) = arr(r)
arr(r) = arr(x)
x = x - 1
Wend
[a1:f1] = rarr
ctr = 0
End Sub
Sub Button1_Click()
Cells(ctr + 3, 1) = rarr(ctr)
ctr = ctr + 1
If ctr > UBound(rarr) Then init
End Sub
and add two buttons to the worksheet. Point one at init and the other at Button1_Click. Click init first, and then pressing Button1 displays a random and unique entry one at a time.
You could create a second array of Booleans, having the same length.
This array is initialized with only False. If a value from your array is selected by the rand, then set the boolean array matching value to True. And if the rand value next time is on a value which has already been selected (with a True in the boolean array), do the rand again
Try this little example step by step, you'll see the logic:
Sub Select_Random_Item_From_1D_Array()
Dim arr(), x As Long, cpt As Long
Dim mBool(2) As Boolean
cpt = 0
arr = Array("Good", "Very Good", "Excellent")
Do While cpt < 3 '3 being the number of items in your array + 1 (from 0 to 2)
Randomize
x = Int((UBound(arr) + 1) * Rnd + 1)
If mBool(x - 1) = False Then
mBool(x - 1) = True
Debug.Print arr(x - 1)
cpt = cpt + 1
End If
Loop
End Sub
It will print a random item from your array, and every time it does so it changes the matching value of the 2nd array from False to True. Then it does it again and if it has already been printed (if the matching value on the boolean array is True) it tries again.
I added a variable named cpt, which goes from 0 to the number of items in your array, it makes the algorithm stop when it has printed all the items one time.
This is probably not he best way to do what you want, but it works and it's not that complicated
Select Random Item Series
Option Explicit
Sub resetRandomItem()
getRandomItem
End Sub
Sub selectRandomItem()
Dim arr As Variant
arr = Array("Bad", "Better", "Good", "Very Good", "Excellent")
Debug.Print getRandomItem(arr)
End Sub
' If x elements in 1D array, it returns a series of x different values.
Function getRandomItem(Optional Data1D As Variant) As Variant
Static arr As Variant
' Reset 'arr': use 'getRandomItem' without 'Data1D' parameter.
If IsMissing(Data1D) Then arr = Empty: Exit Function
If IsEmpty(arr) Then arr = Data1D
Dim lb As Long: lb = LBound(arr)
Dim ub As Long: ub = UBound(arr)
If lb = ub Then
getRandomItem = arr(lb)
arr = Empty
Else
Randomize
Dim x As Long: x = Int((ub - lb + 1) * Rnd + 1)
Dim y As Long: y = x + lb - 1
getRandomItem = arr(y)
arr(y) = Empty
Dim i As Long, k As Long
For i = lb To ub - 1
If arr(i) = Empty Then
For k = i + 1 To ub
arr(k - 1) = arr(k)
Next k
Exit For
End If
Next i
ReDim Preserve arr(ub - 1)
End If
End Function

Is there a way evenly assign employees to a large task list while accounting for some criteria conditions?

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

Generate n random numbers Summed upto cell value Vba code

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

Resources