Please Help with Random number generator...

[Kishan]

Using Excel 2000

Hi,

Given example below I am using formula =ALEATORIO.ENTRE(C$3,C$5) in cell C8 copied across down to P29, column Q has sum of each rows

Conditions each column C:P use lower Num & Higher Num as per row 3 & 4, for example column C to H use num 2 & 4, column I use num 3 & 5, column J use num 1 & 3, like this so on...till Column P

Formula generate combinations as shown with any sum, but the problem is I need VBA help that can generate row only with sum 43, like Row 8, 13, 14, 19, 21

Does it can be done?

Example data.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1
2
3		Lower Num	2	2	2	2	2	2	3	1	3	1	3	3	3	0
4
5		Higher Num	4	4	4	4	4	4	5	3	5	3	5	5	5	2
6
7			C1	C2	C3	C4	C5	C6	C7	C8	C9	C10	C11	C12	C13	C14	Sum Row
8			2	3	3	3	2	4	5	1	5	3	5	4	3	0	43
9			2	2	2	4	2	3	3	2	4	2	4	4	4	1	39
10			4	3	4	3	2	3	5	3	4	2	5	5	4	2	49
11			3	3	3	4	2	4	5	2	5	3	4	4	5	0	47
12			3	2	3	3	2	4	3	3	4	2	5	5	4	2	45
13			4	3	2	3	3	4	5	2	3	2	3	4	4	1	43
14			4	2	3	3	2	2	5	3	5	2	3	4	3	2	43
15			3	4	2	4	3	3	5	1	3	2	4	5	4	2	45
16			4	3	3	4	3	2	3	1	4	2	3	4	3	0	39
17			4	3	2	4	3	3	3	3	3	3	3	5	3	1	43
18			2	3	4	4	4	2	4	3	5	2	5	3	3	1	45
19			4	4	4	2	2	2	5	2	5	1	3	3	5	1	43
20			3	4	2	3	3	2	5	2	3	3	3	5	3	1	42
21			3	2	2	3	3	2	3	2	5	3	5	3	5	2	43
22			3	3	3	2	2	2	3	2	3	3	4	3	5	1	39
23			2	3	2	3	3	2	3	2	4	2	5	4	3	0	38
24			4	2	4	2	2	4	5	3	5	1	3	3	5	2	45
25			3	2	2	2	4	2	4	3	5	2	4	4	4	1	42
26			4	4	4	4	3	4	3	2	5	3	3	5	4	1	49
27			4	3	2	2	3	4	3	2	5	3	3	5	5	0	44
28			2	3	3	2	4	3	4	3	3	2	4	5	3	1	42
29			2	4	4	3	2	2	5	3	4	1	4	5	5	2	46
30
31
Sheet1

Thank you in advance

Regards,
Kishan

 

[Kishan]

Hi, I did search in Mr.Excel and I am sure here is not asked such a random question.</SPAN></SPAN>

Please Help</SPAN></SPAN>

Regards,</SPAN>
Kishan</SPAN> </SPAN>

 

[Kishan]

Hi, If not VBA any formula suggestions ?

 

[Kishan]

Hi, after deep search within MrExcel I find very similar solution to my query under this link; </SPAN></SPAN>

https://www.mrexcel.com/forum/excel-questions/242354-generating-set-random-numbers-total-set-value-2.html#post4435775</SPAN></SPAN>

Adapted to my necessity but find having "Number of random numbers = 14" it don't work as it should working for "Number of random numbers = 5"</SPAN></SPAN>

Here is the adapted formula example.... </SPAN></SPAN>

I think VBA will be the ideal solution for my request</SPAN></SPAN>

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	Num Of Rand
2	Numbers	Lower Num	2	2	2	2	2	2	3	1	3	1	3	3	3	0
3	14
4		Higher Num	4	4	4	4	4	4	5	3	5	3	5	5	5	2
5
6
7
8			C1	C2	C3	C4	C5	C6	C7	C8	C9	C10	C11	C12	C13	C14	Sum
9			2	4	3	3	3	3	4	3	3	3	3	3	3	3	43
10
11
12
13
Sheet2

Cell Formulas
Range	Formula
C9	=RANDBETWEEN(MAX($C$2,Q9-(($A$3-COLUMNS($C9:C9))*$C$4)),MIN($C$4,Q9-(($A$3-COLUMNS($C9:C9))*$C$2)))
D9	=IF(COLUMN()=$A$3+COLUMN($C$9)-1,$Q9-SUM($C9:C9),IF(COLUMN()>$A$3+COLUMN($C$9)-1,"",RANDBETWEEN(MAX(D$2,$Q9-(SUM($C9:C9)+($A$3-COLUMNS($C9:D9))*D$4)),MIN(D$4,$Q9-(SUM($C9:C9)+($A$3-COLUMNS($C9:D9))*D$2)))))

Thank you in advance</SPAN></SPAN>

Regards,</SPAN></SPAN>
Kishan</SPAN> </SPAN>

 

[shg]

A​

B​

C​

D​

E​

F​

G​

H​

I​

J​

K​

L​

M​

N​

O​

P​

Q​

R​

1​

Min​

2​

2​

2​

2​

2​

2​

3​

1​

3​

1​

3​

3​

3​

0​

29​

2​

3​

C1​

C2​

C3​

C4​

C5​

C6​

C7​

C8​

C9​

C10​

C11​

C12​

C13​

C14​

Sum​

4​

3​

3​

4​

4​

2​

2​

3​

2​

4​

3​

3​

5​

5​

0​

43​

B4:O4: {=RandLen(43 - $P$1, , 2) + $B$1:$O$1}

5​

3​

3​

2​

4​

2​

4​

3​

3​

5​

2​

4​

3​

4​

1​

43​

6​

2​

4​

2​

3​

3​

3​

4​

3​

5​

1​

5​

3​

5​

0​

43​

7​

2​

4​

4​

2​

2​

3​

4​

3​

3​

3​

4​

4​

5​

0​

43​

8​

2​

4​

4​

3​

2​

3​

3​

2​

4​

1​

3​

5​

5​

2​

43​

9​

2​

4​

2​

2​

4​

3​

4​

3​

3​

3​

5​

4​

4​

0​

43​

10​

4​

3​

3​

4​

2​

3​

4​

2​

3​

2​

3​

5​

5​

0​

43​

11​

4​

4​

2​

2​

3​

3​

3​

1​

5​

3​

5​

3​

3​

2​

43​

12​

4​

3​

3​

4​

2​

4​

3​

3​

5​

1​

4​

4​

3​

0​

43​

13​

2​

4​

2​

3​

3​

4​

5​

3​

3​

2​

3​

4​

3​

2​

43​

14​

3​

2​

3​

4​

2​

2​

4​

2​

5​

1​

5​

3​

5​

2​

43​

15​

3​

3​

4​

2​

4​

3​

4​

1​

4​

2​

4​

4​

3​

2​

43​

16​

4​

4​

2​

4​

2​

4​

3​

3​

3​

2​

4​

4​

3​

1​

43​

17​

4​

3​

2​

3​

2​

4​

3​

3​

3​

1​

5​

5​

3​

2​

43​

Function RandLen(iTot As Long, _
                 Optional iMin As Long = 0&, _
                 Optional iMax As Long = 2147483647, _
                 Optional bDist As Boolean = False, _
                 Optional bVolatile As Boolean = False) As Long()

  ' shg 2011, 2018 (added iMax)
  ' UDF wrapper for aiRandLenMinMax

  Dim aiTmp()       As Long
  Dim aiOut()       As Long
  Dim iRow          As Long
  Dim nRow          As Long
  Dim iCol          As Long
  Dim nCol          As Long

  If bVolatile Then Application.Volatile

  nRow = Application.Caller.Rows.Count
  nCol = Application.Caller.Columns.Count

  aiTmp = aiRandLenMinMax(iTot, nRow * nCol, iMin, iMax, bDist)
  ReDim aiOut(1 To nRow, 1 To nCol)

  For iRow = 1 To nRow
    For iCol = 1 To nCol
      aiOut(iRow, iCol) = aiTmp((iRow - 1) * nCol + iCol)
    Next iCol
  Next iRow

  RandLen = aiOut
End Function

Function aiRandLenMinMax(ByVal iTot As Long, _
                         k As Long, _
                         Optional ByVal iMin As Long = 0&, _
                         Optional ByVal iMax As Long = 2147483647, _
                         Optional bDist As Boolean = False) As Long()

  ' shg 2011, 2018
  ' VBA only

  Dim ai()          As Long   ' initially cuts, and then lengths
  Dim i             As Long
  Dim iCut          As Long
  Dim iTmp          As Long

  If k < 1 Then Exit Function
  If iMin < 0 Then iMin = 0
  If iTot < k * iMin Then Exit Function
  If iMax < iTot \ k Then Exit Function

  If iMax > iTot Then iMax = iTot
  iTot = iTot - k * iMin                         ' accommodate min
  If bDist Then iTot = iTot - k * (k - 1&) \ 2&  ' accommodate distinct

  ReDim ai(1 To k + 1)

  ' make cuts at intervals that ensure values w/in max
  For i = 0& To iTot Step iMax - iMin - IIf(bDist, k - 1&, 0&)
    iCut = iCut + 1&
    ai(iCut) = i
  Next i

  ' there must be a cut at the top of the string
  If ai(iCut) <> iTot Then
    iCut = iCut + 1&
    ai(iCut) = iTot
  End If

  ' make the rest of the cuts
  For iCut = iCut + 1& To k + 1&
    ai(iCut) = Int(Rnd() * (iTot + 1&))
  Next iCut

  ' sort the cuts and measure the lengths between
  InsertionSort ai
  For i = 1 To k
    iTmp = ai(i)
    ai(i) = ai(i + 1&) - iTmp + iMin
  Next i

  ' get rid the the extra entry
  ReDim Preserve ai(1& To k)

  If bDist Then
    InsertionSort ai

    For i = 1 To k
      ai(i) = ai(i) + i - 1&
    Next i

    FYShuffle1D ai
  End If

  aiRandLenMinMax = ai
End Function

Sub FYShuffle1D(av As Variant)
  ' shg 2015

  ' In-situ Fisher-Yates shuffle of 1D array av
  ' VBA only

  Dim iLB           As Long
  Dim iTop          As Long
  Dim vTmp          As Variant
  Dim iRnd          As Long

  iLB = LBound(av)
  iTop = UBound(av) - iLB + 1

  Do While iTop
    iRnd = Int(Rnd * iTop)
    iTop = iTop - 1
    vTmp = av(iTop + iLB)
    av(iTop + iLB) = av(iRnd + iLB)
    av(iRnd + iLB) = vTmp
  Loop
End Sub

Function InsertionSort(ByRef av As Variant) As Boolean
  ' Sorts 1D or 2D array av in situ; if 2D, one dimension must be 1

  Dim iLB           As Long
  Dim iUB           As Long
  Dim LB            As Long
  Dim i             As Long
  Dim j             As Long
  Dim v             As Variant

  Select Case NumDim(av)
    Case 0, Is > 2
      ' not an array, or > 2 dimensions

    Case 1
      iLB = LBound(av)
      iUB = UBound(av)

      For i = iLB + 1 To iUB
        v = av(i)

        For j = i - 1 To iLB Step -1
          If av(j) <= v Then Exit For
          av(j + 1) = av(j)
        Next j

        av(j + 1) = v
      Next i
      InsertionSort = True

    Case 2
      If UBound(av, 1) - LBound(av, 1) > 0 Then
        If UBound(av, 2) - LBound(av, 2) > 0 Then Exit Function

        iLB = LBound(av, 1)
        iUB = UBound(av, 1)
        LB = LBound(av, 2)

        For i = iLB + 1 To iUB
          v = av(i, LB)

          For j = i - 1 To iLB Step -1
            If av(j, LB) <= v Then Exit For
            av(j + 1, LB) = av(j, LB)
          Next j

          av(j + 1, LB) = v
        Next i
        InsertionSort = True

      Else
        iLB = LBound(av, 2)
        iUB = UBound(av, 2)
        LB = LBound(av, 1)

        For i = iLB + 1 To iUB
          v = av(LB, i)

          For j = i - 1 To iLB Step -1
            If av(LB, j) <= v Then Exit For
            av(LB, j + 1) = av(LB, j)
          Next j

          av(LB, j + 1) = v
        Next i
        InsertionSort = True
      End If
  End Select
End Function

Function NumDim(av As Variant) As Long
  Dim i             As Long

  If TypeOf av Is Range Then
    If av.Cells.Count = 1 Then NumDim = 0 Else NumDim = 2

  ElseIf IsArray(av) Then
    On Error GoTo Done

    For NumDim = 0 To 6000
      i = LBound(av, NumDim + 1)
    Next NumDim
Done:
    Err.Clear
  End If
End Function

 

[Kishan]

shg, I have no words to express how happy I am </SPAN></SPAN>

Only I must say this one is the Wow!! Random Targets Sum Function</SPAN></SPAN>

I appreciate your valuable time and for giving a key solution</SPAN></SPAN>

Have a great weekend</SPAN></SPAN>

Good Luck</SPAN></SPAN>

Kind Regards,</SPAN></SPAN>
Kishan </SPAN></SPAN>

 

[shg]

You're welcome.