Avatar of Euro5
Euro5
Flag for United States of America asked on

Create Random lists based on conditions

Help! I need to create random lists to make weekly calls - 15 calls per day.

There are three classifications, Find, Get & Keep.
Find includes exno gr, ex no int, gr no fr, & mktFR, mkt
Get includes New, No gain, no call, not actiated
Keep includes no pricing, bottom decline, top gain, need fsa

There are two methods, CHOICE ONE is to chose a % of classifications for the week.
For example, 40% FIND, 40% Get & 20% KEEP
Total 75 30 FIND 30 Keep 15 Keep
CHOICE TWO is to divide by thirds, each day
Monday 5 find, 5 get 5 keep

There are two tabs that include these lists.

It is important that they should be random each time they are run.
I have included a RUN button to attach macro.

The first two tabs have lists, the second is PREPLAN where calculations should be run.
The last two sheets are just examples of each method results.
Those tab are not accurate - just a visual of what the result should be.
SAMPLECYCLE.xlsm
Microsoft ExcelMicrosoft Office

Avatar of undefined
Last Comment
Euro5

8/22/2022 - Mon
Robberbaron (robr)

attached is my code that appears to match your example.

not quite sure how you want the macro to start ?  Is output always to the "PrePlan" worksheet ?

currently macro just writes to the Sample sheets

Option Explicit
'vers 2 Robberbaron @EE
Sub RUN()
    If Range("Choice") = "CHOICE ONE" Then
        Main 1
    ElseIf Range("Choice") = "CHOICE TWO" Then
        Main 2
    End If
End Sub
Sub Test1()

    Main 1
End Sub
Sub test2()
    Main 2
End Sub
Sub Main(optionx As Integer)

    Dim rList As Range
    
    
    Set rList = Worksheets("LIST").UsedRange
    Set rList = rList.Resize(rList.Rows.Count, rList.Columns.Count + 2)
    
    Select Case optionx
    Case 1
        ProcessChoice1 rList
    Case 2
        ProcessChoice2 rList
    End Select
    

End Sub

Sub ProcessChoice1(rngList As Range)

    Dim PercFind As Integer, PercGet As Integer, PercKeep As Integer
    Dim TotalFind As Integer, TotalGet As Integer, TotalKeep As Integer
    Dim CountFind As Integer, CountGet As Integer, CountKeep As Integer
    Dim xFlag As String, xClassification As String
    
    
    Dim rngOutput As Range, i As Integer, fnd As Boolean
    
    
    Const ShtOneName = "Sample of ONE"
    
    PercFind = Worksheets(ShtOneName).Range("Find").Value
    PercGet = Worksheets(ShtOneName).Range("Get").Value
    PercKeep = Worksheets(ShtOneName).Range("Keep").Value
    
    'weekly totals
    Const WeekTotal = 75
    TotalFind = WeekTotal * PercFind / 100
    TotalGet = WeekTotal * PercGet / 100
    TotalKeep = WeekTotal * PercKeep / 100
    
    CountFind = 0: CountGet = 0: CountKeep = 0
    
    'set up
    Randomize Timer
    For i = 2 To rngList.Rows.Count
        rngList(i, 5).Value = ""
    Next i
    Set rngOutput = Worksheets(ShtOneName).Range("D2")
    
    Do While (CountFind < TotalFind Or CountGet < TotalGet Or CountKeep < TotalKeep)
        i = Int((rngList.Rows.Count - 1) * Rnd + 1)
        fnd = False
        If rngList(i, 5).Value <> "" Then
            'already used
         Else
            xFlag = rngList(i, 2).Value
            xClassification = GetClassification(xFlag)
        
            Select Case xClassification
            Case "Find"
                If CountFind < TotalFind Then
                    CountFind = CountFind + 1
                    rngList(i, 5).Value = xClassification
                    fnd = True
                End If
            Case "Get"
                If CountGet < TotalGet Then
                    CountGet = CountGet + 1
                    rngList(i, 5).Value = xClassification
                    fnd = True
                End If
            Case "Keep"
                If CountKeep < TotalKeep Then
                    CountKeep = CountKeep + 1
                    rngList(i, 5).Value = xClassification
                    fnd = True
                End If
            End Select
            If fnd Then
                rngOutput.Offset(0, 1).Value = UCase(xClassification)
                rngOutput.Offset(0, 2).Value = UCase(xFlag)
                rngOutput.Offset(0, 3).Value = rngList(i, 3).Value
                rngOutput.Offset(0, 4).Value = rngList(i, 4).Value
                Set rngOutput = rngOutput.Offset(1, 0)
            End If
        End If
    Loop
End Sub

Sub ProcessChoice2(rngList As Range)

    Dim PercFind As Integer, PercGet As Integer, PercKeep As Integer
    Dim TotalFind As Integer, TotalGet As Integer, TotalKeep As Integer
    Dim CountFind As Integer, CountGet As Integer, CountKeep As Integer
    Dim xFlag As String, xClassification As String
    
    
    Dim rngOutput As Range, i As Integer, fnd As Boolean, dayx As Integer
    
    Const ShtName = "Sample of TWO"
    
    'weekly totals
    Const WeekTotal = 75
    'daily totals
    TotalFind = 5
    TotalGet = 5
    TotalKeep = 5
    
    
    'set up
    Randomize Timer
    
    'clear column 6
    For i = 2 To rngList.Rows.Count
        rngList(i, 6).Value = ""
    Next i
    Set rngOutput = Worksheets(ShtName).Range("D2")
    
    'weekdays
    For dayx = 1 To 5
        CountFind = 0: CountGet = 0: CountKeep = 0
        
        Do While (CountFind < TotalFind Or CountGet < TotalGet Or CountKeep < TotalKeep)
            i = Int((rngList.Rows.Count - 1) * Rnd + 1)
            fnd = False
            'column 6 for Choice2
            If rngList(i, 6).Value <> "" Then
                'already used
             Else
                xFlag = rngList(i, 2).Value
                xClassification = GetClassification(xFlag)
            
                Select Case xClassification
                Case "Find"
                    If CountFind < TotalFind Then
                        CountFind = CountFind + 1
                        rngList(i, 6).Value = xClassification
                        fnd = True
                    End If
                Case "Get"
                    If CountGet < TotalGet Then
                        CountGet = CountGet + 1
                        rngList(i, 6).Value = xClassification
                        fnd = True
                    End If
                Case "Keep"
                    If CountKeep < TotalKeep Then
                        CountKeep = CountKeep + 1
                        rngList(i, 6).Value = xClassification
                        fnd = True
                    End If
                End Select
                If fnd Then
                    rngOutput.Offset(0, 1).Value = UCase(xClassification)
                    rngOutput.Offset(0, 2).Value = UCase(xFlag)
                    rngOutput.Offset(0, 3).Value = rngList(i, 3).Value
                    rngOutput.Offset(0, 4).Value = rngList(i, 4).Value
                    Set rngOutput = rngOutput.Offset(1, 0)
                End If
            End If
        Loop
    Next dayx
End Sub

Function GetClassification(thisFlag As String) As String
    Dim rx As Range
    For Each rx In Worksheets("Settings").Range("Classifications").Rows
        If rx.Cells(1, 1).Value = thisFlag Then
            GetClassification = rx.Cells(1, 2).Value
            Exit Function
        End If
    Next rx
    GetClassification = "ERROR"

End Function

Open in new window

SAMPLECYCLE-v2.xlsm
Euro5

ASKER
robberbaron,
The results should always be in the preplan. I put a button there that is labeled RUN, I was hoping to use that to initiate the script.
I think that you have the solution for me, but I am at a loss on how to run, so I can't say for sure! :) Sorry!
Can you try to put the results in the preplan and clear each time running?

Thanks SO MUCH!!
Euro5

ASKER
Also, the Sample of two should be filled in complete for the week - your example only fills in for Monday...
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
Euro5

ASKER
NONO sorry, my mistake!
I get it now...this looks great!.....can we get it to return in preplan? SO NICE!
Robberbaron (robr)

yes can get it to place all output in the preplan . I had thought that was a planning ever only. will have a few hours before I get home
Robberbaron (robr)

all works to activesheet so you should be able to have multiple copies of the 'preplan' sheet,
SAMPLECYCLE-v3.xlsm
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
Euro5

ASKER
This is really perfect. Question, it is writing in the third column on the list. I have data there on the actual report and it is clearing the column and writing this in. Can we eliminate that?

Perhaps I can give you all the points thus far - since you have done such a great job, then I can open a new question? Again, thanks so much for this, it is really a life saver.
Robberbaron (robr)

my routine needs a method to determine if an Id has been used as part of the random selection.

Needs to be a cell beside the id's and you example didnt have anything there.

 I guess the best way is to actually insert a column and then remove it when routine is done.
Will this make a mess of other formatting, like merged cells ?
Euro5

ASKER
No, it is a very simple list - inserting a column and removing will not effect it.
There are columns of data from A - T right now, but there may even be more when all is said and done...
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23
ASKER CERTIFIED SOLUTION
Robberbaron (robr)

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
Euro5

ASKER
Thanks so much!