Populate numbers to specific range

[YasserKhalil]

Hello everyone
I have numeric values in column A (A1:A5) and in column B I put the number of desired occurence for each number ..
In cell E1 I put the number of the desired rows and in cell F1 I put the number of the desired columns

The desired results would start in cell D10 ...

I need to randomize numbers based on number of occurences in the desired range("D10:G14") ...
Hope it is clear

[shg]

Row\Col	A	B	C	D	E	F
1	Numbers	Reps	Helper
2	5	1	0			C2: =SUM(C1, B1)
3	3	6	1
4	4	3	7
5	2	2	10
6	1	4	12
7	3	4	16
8
9
10	1	2	1	5		A10:D14: {=INDEX($A$2:$A$7, MATCH(randlong() - 1, $C$2:$C$7))}
11	3	3	1	3
12	2	3	4	3
13	3	3	4	3
14	1	3	4	3

Public Function RandLong(Optional iMin As Long = 1, _
                         Optional iMax As Long = -2147483647, _
                         Optional bVolatile As Boolean = False) As Variant

  ' shg 2008

  ' UDF wrapper for aiRandLong -- UDF only!

  ' Returns numbers between iMin and iMax to the calling range

  Dim nRow          As Long     ' rows in calling range
  Dim nCol          As Long     ' columns in calling range
  Dim iRow          As Long     ' row index
  Dim iCol          As Long     ' col index
  Dim aiTmp()       As Long     ' 1D temp array
  Dim aiOut()       As Long     ' output array

  If bVolatile Then Application.Volatile True

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

  ReDim aiOut(1 To nRow, 1 To nCol)
  If iMin = 1 And iMax = -2147483647 Then iMax = nRow * nCol
  aiTmp = aiRandLong(iMin, iMax, nRow * nCol)

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

  RandLong = aiOut
End Function

Public Function aiRandLong(iMin As Long, _
                           iMax As Long, _
                           Optional ByVal n As Long = -1, _
                           Optional bVolatile As Boolean = False) As Long()
  ' shg 2008
  ' UDF or VBA

  ' Returns a 1-based array of n unique Longs between iMin and iMax inclusive

  Dim ai()          As Long     ' array of numbers iMin to iMax
  Dim i             As Long     ' index to ai

  If bVolatile Then Application.Volatile True

  If n < 0 Then n = iMax - iMin + 1
  If iMin > iMax Or n > (iMax - iMin + 1) Or n < 1 Then Exit Function

  ReDim ai(iMin To iMax)

  For i = iMin To iMax
    ai(i) = i
  Next i

  FYShuffle ai
  If n > -1 Then ReDim Preserve ai(iMin To iMin + n - 1)
  aiRandLong = ai
End Function

Sub FYShuffle(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

[YasserKhalil]

Thank you very much Mr. shg for this fascinating solution. It is perfect.
Just a little question : Can I depend on the the cells E1 and F1 to determine the number of rows and number of columns desired ..
And if for example the no of rows = 7 and the no of columns =4 so the no of cells will be = 28 ..As for results would be just 20 in the sample attached ..
So in this case to distribute numbers and the rest of cells ( 28- 20 = 8) which will be eight cells to be empty..
Hope it is clear
Thanks a lot for your great help

[karedog]

Maybe :

Sub Test()
  Dim arrIn, arrTemp, arrOut, i As Long, j As Long, k As Long, p As Long, v

  With Range("A1").CurrentRegion
    arrIn = Range("A1").CurrentRegion.Value
    ReDim arrOut(1 To [E1], 1 To [F1])
    ReDim arrTemp(1 To Application.Max(Application.Sum(.Offset(, 1).Resize(, 1)), UBound(arrOut, 1) * UBound(arrOut, 2)))
  End With

  For i = 1 To UBound(arrIn, 1)
      For j = 1 To arrIn(i, 2)
          p = p + 1
          arrTemp(p) = arrIn(i, 1)
      Next j
  Next i

  j = UBound(arrTemp)
  For i = 1 To UBound(arrTemp)
      k = Int(Rnd() * j) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
  Next i

  p = 0
  For i = 1 To UBound(arrOut, 1)
      For j = 1 To UBound(arrOut, 2)
          p = p + 1
          arrOut(i, j) = arrTemp(p)
      Next j
  Next i

  Range(Range("D10"), ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
  Range("D10").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
End Sub

[YasserKhalil]

Mr. Karedog
You are perfect ... this is very very awesome solution
Thank you very much for this great and wonderful gift

[karedog]

You are welcome, glad to help.


Regards

[sourabhg98]

I also tried making a macro-

Sub randomrange()
Dim rng As Range
Dim cell As Range
l1 = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
l2 = 1
For n = 1 To l1
Sheets("Random").Range("A" & l2).Resize(Sheets("Sheet1").Range("B" & n).Value).Value = Sheets("Sheet1").Range("A" & n).Value
l2 = Sheets("Random").Range("A" & Rows.Count).End(xlUp).Row + 1
Next n
a = Sheets("Sheet1").Range("E1").Value
b = Sheets("Sheet1").Range("F1").Value
f = 0
Set rng = Sheets("Sheet1").Range("D10").Resize(a, b)
For Each cell In rng
k = Int(((a * b) - f) * Rnd + 1)
cell.Value = Sheets("Random").Range("A" & k).Value
Sheets("Random").Rows(k).Delete
f = f + 1
Next cell
End Sub

For this macro you need to have a helper sheet named "Random".

I know this is not a very good macro but this is what I could make with my limited VBA knowledge.

Check attached.

[YasserKhalil]

Thank you very much Mr. Sourabh for this great solution. It is wonderful and very helpful too
Best Regards

[sourabhg98]

Glad to know that helped!
Thank You for the feedback and reputation.

[sourabhg98]

I just learned how to use the arrays in VBA and made my first code using arrays-
This one works without helper sheet.
I know you have enough solutions, I just wanted to share-

Sub test2()
a = Range("E1").Value
b = Range("F1").Value
Const l = Range("A" & Rows.Count).End(xlUp).Row
Dim arr1(1 To l) As Integer, rng As Range, cell As Range
For n = 1 To l
arr1(n) = Range("B" & n).Value
Next n
f = 0
Set rng = Range("D10").Resize(a, b)
For Each cell In rng
s = 1
ReDim arr2(1 To (a * b) - f, 1 To 2) As Integer
    For y = 1 To l
        For r = 1 To arr1(y)
        arr2(s, 1) = Range("A" & y).Value
        arr2(s, 2) = y
        s = s + 1
        Next r
    Next y
random = Int(((a * b) - f) * Rnd + 1)
cell.Value = arr2(random, 1)
f = f + 1
arr1(arr2(random, 2)) = arr1(arr2(random, 2)) - 1
Next cell
End Sub

[YasserKhalil]

Thanks a lot for plenty solution but it doesn't work ..it gives errors

[sourabhg98]

Error Rectified-

Sub test2()
a = Range("E1").Value
b = Range("F1").Value
Dim l As Integer, rng As Range, cell As Range
l = Range("A" & Rows.Count).End(xlUp).Row
ReDim arr1(1 To l) As Integer
For n = 1 To l
arr1(n) = Range("B" & n).Value
Next n
f = 0
Set rng = Range("D10").Resize(a, b)
For Each cell In rng
s = 1
ReDim arr2(1 To (a * b) - f, 1 To 2) As Integer
    For y = 1 To l
        For r = 1 To arr1(y)
        arr2(s, 1) = Range("A" & y).Value
        arr2(s, 2) = y
        s = s + 1
        Next r
    Next y
random = Int(((a * b) - f) * Rnd + 1)
cell.Value = arr2(random, 1)
f = f + 1
arr1(arr2(random, 2)) = arr1(arr2(random, 2)) - 1
Next cell
End Sub

[YasserKhalil]

Thanks a lot for this great solution. Now it works like charm
Best regards