Insert random data from a set to ranges Nth times

E

ENEMALI

Board Regular
Joined
Aug 9, 2011
Messages
60
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
SUBJECTSOCCURRENCEMONDAY
2
MATH5TUESDAY
3
SCIENCE3WEDNESDAY
4
SPORT2THURSDAY
5
ENGLISH5FRIDAY
6
CRAFT2
7
MUSIC1

<tbody>
</tbody>
 
Last edited:

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG21Apr36
[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
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2:A5")
Range("F1:J5").ClearContents
Randomize
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
             n = 0
            [COLOR="Navy"]Do[/COLOR] Until n >= Dn.Offset(, 1).Value
                txt = "": c = 0
                RndRw = Int(Rnd * Dn.Offset(, 1).Value) + 1
                [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 = Int(Rnd * UBound(Ray)) + 1
                    Cells(RndRw, Ray(Num)) = Dn
                    n = n + 1
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Loop[/COLOR]
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick's code isn't working for me (maybe Rng should be A2:A7 like the OPs layout, not A2:A5 like the OPs words ?). Here's an alternative macro.
Code: 
Sub FillSchedule()
Dim R As Range, c As Range, Rall As Range, Vsubjects As Variant, Vsched As Variant, i As Long, j As Long
Dim ct As Long, x As Long, z As String

Set R = Range("A1").CurrentRegion.Offset(1, 0).Resize(Range("A1").CurrentRegion.Rows.Count - 1, 2)
ReDim Vsubjects(1 To WorksheetFunction.Sum(R.Columns(2)))
For Each c In R.Columns(2).Cells
       For i = 1 To c.Value
              ct = ct + 1
              Vsubjects(ct) = c.Offset(0, -1).Value
       Next i
Next c
ct = 0
Set Rall = Range("F1:J5")
Application.ScreenUpdating = False
Rall.ClearContents
Vsched = Rall.Value
Do
    Rall.Value = Vsched
    i = WorksheetFunction.RandBetween(1, Rall.Rows.Count)
    j = WorksheetFunction.RandBetween(1, Rall.Columns.Count)
    If IsEmpty(Rall.Cells(i, j)) Then
        x = WorksheetFunction.RandBetween(1, UBound(Vsubjects))
        z = Vsubjects(x)
        If Application.CountIf(Rall, z) < R.Columns(2).Cells(Application.Match(z, R.Columns(1), 0)) Then
            If Application.CountIf(Rall.Rows(i), z) = 0 Then
                ct = ct + 1
                Vsched(i, j) = z
                If ct = UBound(Vsubjects) Then
                    Rall.Value = Vsched
                    Exit Sub
                End If
            End If
        End If
    End If
Loop While ct < UBound(Vsubjects)
Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Mick's code isn't working for me (maybe Rng should be A2:A7 like the OPs layout, not A2:A5 like the OPs words ?). Here's an alternative macro.
Click to expand...
thank you JoeMo and MickG
sorry that was an error in my post Rng should be A2:A7 not A2:A5 because i noticed CRAFT and MUSIC were omitted from the output , but after changing it to A2:A7 and run it , an error message pops up saying runtime error '1004' no cells found then the code below is highlighted yellow
Code: 
Set R = Cells(RndRw, 6).Resize(, 5).SpecialCells(xlCellTypeBlanks)

changing the second parameter 5 to 7 in
Code: 
Resize(, 5)
resolve the error and Mick's code runs fine as shown below

Code: 
Set R = Cells(RndRw, 6).Resize(, [B]7[/B]).SpecialCells(xlCellTypeBlanks)
txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, [B]7[/B]))), ",")

but leaving you with some uneccessary blank cells , i will try to figure out how to handle the blank cells in between subjects per row but i prefer not to have them in between the subjects per each day ( row ) any suggestion on the blank cells in between subjects is welcomed .


also
Code: 
Range("F1:J5").ClearContents
changed to
Code: 
Range("F1:L5").ClearContents

so Mick's new code is

Code: 
Sub MG21Apr36
Set Rng = Range("A2:A7")
Range("F1:L5").ClearContents
Randomize
For Each Dn In Rng
             n = 0
            Do Until n >= Dn.Offset(, 1).Value
                txt = "": c = 0
                RndRw = Int(Rnd * Dn.Offset(, 1).Value) + 1
                Set R = Cells(RndRw, 6).Resize(, 7).SpecialCells(xlCellTypeBlanks)
                txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 7))), ",")
                If InStr(txt, Dn.Value) = 0 Then
                  ReDim Ray(1 To R.Count)
                    For Each col In R
                        c = c + 1
                        Ray(c) = col.Column
                    Next col
                    Num = Int(Rnd * UBound(Ray)) + 1
                    Cells(RndRw, Ray(Num)) = Dn
                    n = n + 1
                End If
            Loop
    Next Dn
End Sub

JoeMo your code works fine according the layout in my original question but i changed the number of OCCURRENCE in column B maybe SPORT becomes 4 , the code goes into something like infinite loop and excel need to be restarted
 
Last edited:
Upvote 0
I've now modified the code as per your new ranges and added slight mods as required:-
Please try as below:-

NB:- I have also tried restricted the code back to "F1:J5", it still works and reduces the blank space to some degree !!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG22Apr17
[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
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2:A7")
Range("F1:L5").ClearContents
Randomize
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
             n = 0
            [COLOR="Navy"]Do[/COLOR] Until n >= Dn.Offset(, 1).Value
                txt = "": c = 0
                RndRw = Int(Rnd * Rng.Count) + 1
                [COLOR="Navy"]If[/COLOR] Not Application.CountA(Cells(RndRw, 6).Resize(, 7)) = 7 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] R = Cells(RndRw, 6).Resize(, 7).SpecialCells(xlCellTypeBlanks)
                    txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 7))), ",")
                    [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 = Int(Rnd * UBound(Ray)) + 1
                        Cells(RndRw, Ray(Num)) = Dn
                        n = n + 1
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Loop[/COLOR]
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
When I change SPORT to 4 I get the results expected. That is, SPORT appears 2 more times in the schedule and there are a total of 20 items in the schedule.

If you want to eliminate blanks between scheduled items then you are departing from the random assignment you have requested. Can be done easily by filling the schedule one row at a time subject to the constraint that no subject appears more than once in any row.
 
Upvote 0
ENEMALI said:
but leaving you with some uneccessary blank cells , i will try to figure out how to handle the blank cells in between subjects per row but i prefer not to have them in between the subjects per each day ( row )
Click to expand...

Why don't you duplicate the table you posted in Message #1 , but manually fill out the cells you want filled with a solution you would consider proper and laid out the way you want so that we do not have to guess at what we think you are trying to describe to us?
 
Upvote 0
Please correct "Typo" to "5" from "Rng.Count"


Code: 
 RndRw = Int(Rnd * [B][COLOR=#FF0000]5[/COLOR][/B]) + 1
 
Upvote 0
Please correct "Typo" to "5" from "Rng.Count"
Click to expand...
This corrected some errors i noticed , thanks for the correction


NB:- I have also tried restricted the code back to "F1:J5"
Click to expand...
to restrict the code to "F1:F5" i guess all the "7" in the code below should be "5" and that was what i did that made the code work as your statement above
Code: 
[COLOR=Navy]
If[/COLOR] Not Application.CountA(Cells(RndRw, 6).Resize(, 7)) = 7 [COLOR=Navy]Then[/COLOR][COLOR=Navy]
Set[/COLOR] R = Cells(RndRw, 6).Resize(, 7).SpecialCells(xlCellTypeBlanks)
txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 7))), ",")

Why don't you duplicate the table you posted in Message #1 , but manually fill out the cells you want filled with a solution you would consider proper and laid out the way you want so that we do not have to guess at what we think you are trying to describe to us?
Click to expand...

A
BCDEFGHIJ
1SUBJECTS
OCCURRENCE MONDAYCRAFTENGLISH MATH
2MATH5 TUESDAYMATHCRAFTENGLISHSPORTSCIENCE
3SCIENCE
3 WEDNESDAYENGLISHSCIENCE MATH
4SPORT
2 THURSDAY MATHENGLISHSPORT
5ENGLISH5 FRIDAY MUSICMATHSCIENCEENGLISH
6CRAFT2
7MUSIC1
8
I would love to see the output like below eliminating blank cell between subjects per row ( if possible)
9TOTAL SUBJECTS (schedule ) PER WEEK 18
MONDAYCRAFT
ENGLISHMATH
10TUESDAYMATHCRAFTENGLISHSPORT
SCIENCE
11WEDNESDAY
ENGLISH
SCIENCE
MATH
12THURSDAYMATHENGLISHSPORT
13FRIDAYMUSICMATHSCIENCE
ENGLISH

<colgroup><col><col><col><col><col><col><col><col span="2"><col><col></colgroup><tbody>
</tbody>


i guess to eliminate the blank cells between subjects in each row in the output i will do the following
  1. After the code to randomly distribute subjects ran
  2. a code to loop through each cell in each row in range("F1:J5") not column
  3. while looping check if the cell is not blank , check again the cell left to it , if it is blank , tranfer/copy the non blank cell content to the left blank cell then clear/delete the non blank cell after the tranfer/copy

never mind ignorance
 
Upvote 0
Try the code below:-
NB:- Range("A2:A7") is the "Lesson Type" not to be confused with the code below, that refers to range("F1:J5")
If you change the 7 as in the "Resize(,7) as below you are in fact changing the results range("F1:J5") to range("F1:L5") , which I don't think you want !!!!
If Not Application.CountA(Cells(RndRw, 6).Resize(, 7)) = 7 ThenSet R = Cells(RndRw, 6).Resize(, 7).SpecialCells(xlCellTypeBlanks)
txt = Join(Application.Transpose(Application.Transpose(Cells(RndRw, 6).Resize(, 7))), ",")
Click to expand...

NB:- If the Total in column "B" ever reaches or gets close to 25 (The number of results cells available) The results may not be computable, so as a get out I have Included a loop maximum of 10k so the program does not go into an endless loop or crashes.
If this happens you will see a notice to "Try again ", until you receive a "Success" Msgbox .
NB:- The code also moves the Blank cells to the left.

This is far from perfect but, seems to work !!!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG23Apr12
[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="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
             n = 0
            [COLOR="Navy"]Do[/COLOR] Until n >= Dn.Offset(, 1).Value
                txt = "": c = 0
                RndRw = Application.RandBetween(1, 5)
                p = p + 1
                [COLOR="Navy"]If[/COLOR] p >= 10000 [COLOR="Navy"]Then[/COLOR] GoTo xt
                [COLOR="Navy"]If[/COLOR] Not Application.CountA(Cells(RndRw, 6).Resize(, 5)) = 5 [COLOR="Navy"]Then[/COLOR]
                    [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
                        n = n + 1
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Loop[/COLOR]
    [COLOR="Navy"]Next[/COLOR] Dn
[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
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Count if with multiple condilition
Replies
3
Views
79
awoohaw
awoohaw
katsdelite
  • Solved
Help with formula
Replies
4
Views
121
dreid1011
dreid1011
Z
  • Solved
Putting data into separate cells from one cell - breaking up an untidy list
Replies
8
Views
323
Fluff
Fluff
T
  • Solved
Copy data from workbook where filename and tab name match
Replies
5
Views
661
TaskMaster
T
S
  • Solved
Automating Company Holidays on calendar
Replies
4
Views
597
saracat2012
S

Forum statistics

Threads
1,214,641
Messages
6,120,694
Members
448,979
Latest member
DET4492

Share this page

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top