# help modifiying code

#### abberyfarm

##### Well-known Member
Hi there,

Would anybody be able to help me make a slight modification to the code below.

Code:
``````[LEFT]Sub RandomQuicker()
Dim a&, b&, c&, i&, j&, tbl()
Randomize
For i = 2 To 10
If Cells(i, 1).Value = 1 Then
Cells(i, 3).Value = Cells(i, 2).Value
Else
If Cells(i, 1).Value = 2 Then
Cells(i, 3).Value = Int(1 + Rnd * Cells(i, 2).Value)
Cells(i, 4).Value = Cells(i, 2).Value - Cells(i, 3).Value
Else
a = Cells(i, 1).Value
b = Cells(i, 2).Value
ReDim Preserve tbl(1 To a - 1)

For j = 1 To a - 1
tbl(j) = Int((1 + b * Rnd))
Next j

c = Application.Sum(tbl)

For j = 1 To a - 1
tbl(j) = Int(tbl(j) / (1.1 * c) * b)
Next j

c = Application.Sum(tbl)

ReDim Preserve tbl(1 To a)
tbl(a) = b - c
Cells(i, 3).Resize(, UBound(tbl)) = tbl
End If
End If
Next i
End Sub

[/LEFT]``````

This code divides up the total distance travelled into individual journey distances based on the number of journeys.

Excel Workbook
ABCDEF
1No .TripsTotal travelIndividual travel
2210515
33203512
44405101213
Sheet1

I need to prevent it from generating 0 as a random number as 0 distance would not make sense. I believe I need to change the conditions for the array tbl, but I am not entirely sure.

Thank for help

John

Last edited:

### Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Hi John,

Does this help as an alternative?
Code:
``````[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Option Explicit

Sub RandomQuicker()

Dim tbl()
Dim iTrips As Integer, iSum As Integer
Dim lRow As Long, lLastRow As Long
Dim dRnd As Double

lLastRow = Range("A" & Rows.Count).End(xlUp)
Randomize
For lRow = 2 To lLastRow
ReDim tbl(1 To Cells(lRow, 1))
[COLOR="Green"]        '*
'* Generate random number within the limit of the value column B[/COLOR]
For iTrips = 1 To Cells(lRow, 1)
dRnd = Rnd
tbl(iTrips) = IIf(Int(dRnd * Cells(lRow, 2) / Cells(lRow, 1)) = 0, 1, Int(dRnd * Cells(lRow, 2) / Cells(lRow, 1)))
Next iTrips
[COLOR="Green"]        '*
'* Apply correction factor, if need be[/COLOR]
iSum = Application.Sum(tbl)
If iSum <> Cells(lRow, 2) Then
For iTrips = 1 To Cells(lRow, 1)
tbl(iTrips) = Round(Cells(lRow, 2) / iSum * tbl(iTrips), 0)
Next iTrips
End If
[COLOR="Green"]        '*
'* If still some differences, distribute amongst tbl elements[/COLOR]
iSum = Application.Sum(tbl)
If iSum <> Cells(lRow, 2) Then
For iTrips = 1 To Cells(lRow, 1)
If iSum > Cells(lRow, 2) Then
tbl(iTrips) = tbl(iTrips) - 1
iSum = iSum - 1
Else
tbl(iTrips) = tbl(iTrips) + 1
iSum = iSum + 1
End If
If iSum = Cells(lRow, 2) Then Exit For
Next iTrips
End If
Cells(lRow, 3).Resize(, Cells(lRow, 1)) = tbl
Next lRow

End Sub[/COLOR][/SIZE][/FONT]``````

Thank you very much for your help. This works perfect.

Regards

John

Al-hamdullah, you are most welcome and thank you for the feedback!
Best regards

Thank you for help recently with this problem.

Would you mind explaining to me briefly how the code works? I've tried to understand it but I cannot follow it.

Do you begin by generating one random number within the limit of column B? what happens next? what is the correction factor?

Kind Regards

John

Hi John,

I’ll give it a try, in-sha’ Allah, and explain by example, hoping this make things clearer.

Considering the second option in your example; Number of trips = 3 and number of travels = 20.

Code:
``````[FONT=Consolas][SIZE=2][COLOR=Navy][COLOR=Green]'*
'* Generate random number within the limit of the value column B[/COLOR]
For iTrips = 1 To Cells(lRow, 1)
dRnd = Rnd
tbl(iTrips) = IIf(Int(dRnd * Cells(lRow, 2) / Cells(lRow, 1)) = 0, 1, Int(dRnd * Cells(lRow, 2) / Cells(lRow, 1)))
Next iTrips[/COLOR][/SIZE][/FONT]``````
In this piece of code, the number of travels is divided by the number of trips to set a maximum limit for the initial number of each individual travels (20 / 3 = 6.667). This ensures no random number (initial value) goes beyond this limit.

Why this approach?

If we start with generating random by multiplying Rnd × Total number of travels (20), we might get 19 as a result. So, if 19 goes to one individual travel this leaves the remaining 1 travel to be shared between the other two travels, which is not possible. So, if we go this way then we have to do extensive checks to avoid such situation.

Therefore and for simplicity, the number of travels is divided by the number of trips to ensure balanced distribution of the initial random numbers.

Code:
``````[FONT=Consolas][SIZE=2][COLOR=Navy][COLOR=Green]'*
'* Apply correction factor, if need be[/COLOR]
iSum = Application.Sum(tbl)
If iSum <> Cells(lRow, 2) Then
For iTrips = 1 To Cells(lRow, 1)
tbl(iTrips) = Round(Cells(lRow, 2) / iSum * tbl(iTrips), 0)
Next iTrips
End If[/COLOR][/SIZE][/FONT]``````
Suppose the result of generating the random numbers was; 3, 3 and 2. The sum is 8 which is less than the total of 20.

A correction factor is applied to adjust the initial numbers on a prorate basis using the formula,

Adjusted number = Total number of travels × Initial number / Sum of initial numbers

Accordingly, the numbers after adjustment are;
3 * 20 / 8 = 8
3 * 20 / 8 = 8
2 * 20 / 8 = 5

The total is 21, which is greater than 20. Therefore, further adjustment is required.

Code:
``````[FONT=Consolas][SIZE=2][COLOR=Navy][COLOR=Green]'*
'* If still some differences, distribute amongst tbl elements[/COLOR]
iSum = Application.Sum(tbl)
If iSum <> Cells(lRow, 2) Then
For iTrips = 1 To Cells(lRow, 1)
If iSum > Cells(lRow, 2) Then
tbl(iTrips) = tbl(iTrips) - 1
iSum = iSum - 1
Else
tbl(iTrips) = tbl(iTrips) + 1
iSum = iSum + 1
End If
If iSum = Cells(lRow, 2) Then Exit For
Next iTrips
End If[/COLOR][/SIZE][/FONT]``````

The last adjustment considers whether the sum of random numbers is greater than total travels (as in the example) or less (e.g.: initial numbers; 4, 4 and 3 »»» adjusted; 7, 7 and 5 = 19)

The approach is to distribute the remainder of subtracting total travels from the sum of random numbers amongst the generated numbers.

Back to the example, the remainder is 1, so it will be subtracted from the first number to get the final result; 7, 8 and 5 = 20.

Hope this is clear.

Last edited:

Thank you very much for your effort to explain the code. It's much appreciated and of great help.

Best Regards

John

Al-hamdullah, you're most welcome!
All the best

Replies
4
Views
174
Replies
2
Views
98
Replies
5
Views
287
Replies
0
Views
69
Replies
4
Views
214

1,202,981
Messages
6,052,900
Members
444,610
Latest member
dodong

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back