Insert random data from a set to ranges Nth times

[ENEMALI]

Using formula or VBA , i want to populate a range with some specific data xtimes coming from another range of cells.
my excel sheet is show below. Now i want to

1. randomly fill range F1:J5 with the subjects found in A2:A5
2. the number of occurrence should match the value in B2:B5
3. No subject should Repeat itself in a day (row)

thanks in advance

	A	B	C	D	E	F	G	H	I	J
1	SUBJECTS	OCCURRENCE			MONDAY
2	MATH	5			TUESDAY
3	SCIENCE	3			WEDNESDAY
4	SPORT	2			THURSDAY
5	ENGLISH	5			FRIDAY
6	CRAFT	2
7	MUSIC	1

<tbody>
</tbody>

 

[MickG]

I've Just thought If your Total in column "B" was 25 (Total available results cells) you could always extend the results column by a few to enable the results to be posted, then when you removed all the blank cells the results range would be filled exactly without need for the "Try Again" and "Success" Msgbox .

 

[ENEMALI]

Thanks Mick the code works perfectly as needed , i will also put your suggestion about the Total in column "B" reaching 25 into consideration thanks again.
Not forgetting others for their contribution, i really appreciate all your inputs. You all saved me some hours of tedious manual work

 

[ENEMALI]

simply out of curiosity( just for learning purposes )

1. which part of the restrict the output result to one subject per row ( day )
2. if anyone has the time , in plain English please explain what does each line of the following code does

[COLOR=Navy]
Set[/COLOR] R = Cells(RndRw, 6).Resize(, 5).SpecialCells(xlCellTypeBlanks)
txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 5))), ",")[COLOR=Navy]If[/COLOR] InStr(txt, Dn.Value) = 0 [COLOR=Navy]Then[/COLOR]
ReDim Ray(1 To R.Count)[COLOR=Navy]
For[/COLOR] [COLOR=Navy]Each[/COLOR] col [COLOR=Navy]In[/COLOR] R
c = c + 1
 Ray(c) = col.Column
[COLOR=Navy]Next[/COLOR] col
Num = Application.RandBetween(1, UBound(Ray))
Cells(RndRw, Ray(Num)) = Dn

 

[MickG]

This may Help !!

[COLOR="Navy"]Sub[/COLOR] MG24Apr45
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] RndRw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Col [COLOR="Navy"]As[/COLOR] Range, nCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cRng [COLOR="Navy"]As[/COLOR] Range, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2:A7")
Range("F1:J5").ClearContents
Randomize
'[COLOR="Green"][B]Loop through each value in column "A"[/B][/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
             '[COLOR="Green"][B]set variables to 0[/B][/COLOR]
             n = 0: p = 0
            
            '[COLOR="Green"][B]loop until n equals the Dn.value in column "B"[/B][/COLOR]
            [COLOR="Navy"]Do[/COLOR] Until n >= Dn.Offset(, 1).Value
                
                '[COLOR="Green"][B]set variables to Nullstring and 0[/B][/COLOR]
                txt = "": c = 0
                
                '[COLOR="Green"][B]set random number for rows 1 to 5[/B][/COLOR]
                RndRw = Application.RandBetween(1, 5)
                
               '[COLOR="Green"][B]start counter p to exit if not computable[/B][/COLOR]
                p = p + 1
                [COLOR="Navy"]If[/COLOR] p >= 1000 [COLOR="Navy"]Then[/COLOR] GoTo xt
                
                '[COLOR="Green"][B]Make sure there are blank spaces in row "RndRw" columns "F to j" by counting constants in row[/B][/COLOR]
                [COLOR="Navy"]If[/COLOR] Not Application.CountA(Cells(RndRw, 6).Resize(, 5)) = 5 [COLOR="Navy"]Then[/COLOR]
                    
                    '[COLOR="Green"][B]Create range variabl "R" of cells in row "RndRw" that are Blank[/B][/COLOR]
                    [COLOR="Navy"]Set[/COLOR] R = Cells(RndRw, 6).Resize(, 5).SpecialCells(xlCellTypeBlanks)
                       
                       '[COLOR="Green"][B]Join all text in row "RndRw", as string variable "Txt"[/B][/COLOR]
                       txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 5))), ",")
                    '[COLOR="Green"][B]Check that the Dn.value (lesson) does not already exist in row "Rndrw"[/B][/COLOR]
                    [COLOR="Navy"]If[/COLOR] InStr(txt, Dn.Value) = 0 [COLOR="Navy"]Then[/COLOR]
                       
                       '[COLOR="Green"][B]Create an One dimensional array of size (R.count) (Blank cells in Row "RndRw")[/B][/COLOR]
                        ReDim Ray(1 To R.Count)
                            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Col [COLOR="Navy"]In[/COLOR] R
                                c = c + 1
                            '[COLOR="Green"][B]Place in array "Ray" the column numbers, in columns "F to J" that are blank in row "RndRw"[/B][/COLOR]
                                Ray(c) = Col.Column
                            [COLOR="Navy"]Next[/COLOR] Col
                        
                        '[COLOR="Green"][B]select a random number in array, to get random column Number in row that is empty[/B][/COLOR]
                        Num = Application.RandBetween(1, UBound(Ray))
                        
                        '[COLOR="Green"][B]Place dn.Value (column A) in empty cell in row "RndRw"[/B][/COLOR]
                        Cells(RndRw, Ray(Num)) = Dn
                        
                        '[COLOR="Green"][B]Count number of entries made in range(F1:J5"[/B][/COLOR]
                        n = n + 1
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Loop[/COLOR]
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
'[COLOR="Green"][B]Shift cells left & other bits.[/B][/COLOR]
[COLOR="Navy"]With[/COLOR] Range("F1:J5")
    .SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
    .VerticalAlignment = xlCenter
    .HorizontalAlignment = xlCenter
    .Borders.Weight = xlThick
[COLOR="Navy"]End[/COLOR] With
MsgBox "Success!!"
[COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
xt:
MsgBox "Not Computable, Try again"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ENEMALI]

Thanks

 

[MickG]

You're welcome