VBA or Formula to populate range of cells with set frequency of pre-defined values.

[bartmaster]

Hello,

Please see below table:

Book2
	A	B	C	D	E	F	G
1	Values		Value	Occurrence		New count of values:	65
2	BBB		AAA	10%
3	AAA		AAB	5%			Values:
4	AAB		ABA	15%
5	ABA		ABB	15%
6	AAA		BAA	15%
7	ABB		BAB	15%
8	BAB		BBA	15%
9	BBA		BBB	10%
10	BBB
11	ABA
12	BAB
13	BAA
14	BBA
15	ABB
16	BAA
17	BBA
18	ABA
19	ABB
20	BAB
21	BAA
Sheet1

Cell Formulas
Range	Formula
D2:D9	D2	=COUNTIF($A$2:$A$21,C2)/20

Column C contains a list of distinct values from column A with their percentage distribution in column D.
Easy enough!

The question is how can we revert the process to get a list of pre-defined valuesfrom column C into column G (starting from row 4).
I would want to have them in random order but keeping the set distribution percentage?
Additionally a variable in the cell G1 would tell how many rows we would like to fill, i.e. currently column A has 20 values but in column F we would like to get a list of 65 values.

Any ideas?
Many thanks

 

[Peter_SSs]

Would it be too much to ask you to write a brief step by step explanation?

See below.

Sub New_List()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, Tsum As Long, NewCount As Long
  
  'Required to ensure random numbers generated later are truly random
  Randomize
  'Read existing values & occurrence %s into an array
  a = Range("C2", Range("D" & Rows.Count).End(xlUp)).Value
  'Record the number of new values required
  NewCount = Range("G1").Value
  'Starting at the 2nd value calculate no. of each value required to get the new total ..
  For i = 2 To UBound(a)
    '.. by multiplying the % from col D and the new total no.
    a(i, 2) = Round(a(i, 2) * NewCount, 0)
    'Keep a running total
    Tsum = Tsum + a(i, 2)
  Next i
  'Now calculate the no. required for the 1st value to account for rounding in the other calculations
  a(1, 2) = NewCount - Tsum
  'Create an array to hold the new values
  ReDim b(1 To NewCount, 1 To 2)
  'Work through the 'a' array ..
  For i = 1 To UBound(a)
    '.. to make the required no. of each value, not random at this point
    For j = 1 To a(i, 2)
      'On each row of the 'b' array
      k = k + 1
      'Write the relevant value ..
      b(k, 1) = a(i, 1)
      '.. & beside it a random number
      b(k, 2) = Rnd
    Next j
  Next i
  Application.ScreenUpdating = False
  'In cols G:H & required no. of rows
  With Range("G4:H4").Resize(NewCount)
    'Enter the values & random no.s from the 'b' array
    .Value = b
    'Sort these values by the random no.s in col H
    .Sort Key1:=.Columns(2), Header:=xlNo
    'Now clear out the random no.s
    .Columns(2).ClearContents
  End With
  Application.ScreenUpdating = True
End Sub