Creat Random List

I need to create a file with random purchase list that have some restrictions.
I’ve been working on this file for few days, but I couldn’t get desirable results.
Attached a sample file that describes what I did. It build up as the final file (just the final file has many more items).
I’ll try to explain what I need and how it works:
There are 4 categories: Theater, Salon, Kitchen & garden.
I need to create random lists of purchases (each list should be a line at the total sheet)
there is budget limitation of $100000. Each category has minimum items that must be purchase (headlines are in red color, total of 9 items).
The minimum items that can be on one list are 11 (9 red columns & another 2 random columns). Maximum are 15 items (9 + 6). Same item shouldn’t appear twice at the same list.
This file chooses randomly 19 items and check if the list stands up the budget.
There are 3 issues that I couldn’t solve by myself:
1. I should define the file to stay within minimum & maximum items per list (11-15)
2. Make sure it doesn’t go over the budget
3. Stabilize the list the values will not change each time I’m doing changes to file
I’ll really appreciate who ever can help me with those issues. If someone thinks he has other way that gives me same result it will also be great.

Maybe the attachment will help. It uses a macro to randomise a list of all your items and checks if the top 19 when taken together meet your criteria. You can choose how many answers you want by changing the number in cell G2 on the first tab.

The code on the module1 tab in the VBA editor (Shift F11) is as follows.

Sub Test()
Sheets("Output").Cells.Clear
Do
    Sheets("Data").Cells(1, 1).CurrentRegion.Sort Header:=xlYes, key1:=Sheets("Data").Cells(2, 5)
    If Application.Sum(Sheets("Data").Range("C2:C20")) > 100000 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D20"), "Theater") < 1 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D20"), "Salon") < 3 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D20"), "Kitchen") < 4 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D20"), "Garden") < 1 Then GoTo NotAnOption
    Sheets("Data").Range("A2:D20").Copy Destination:=Sheets("Output").Cells(65536, 1).End(xlUp).Offset(2, 0)
    Counter = Counter + 1
    If Counter = Sheets("Data").Range("G2") Then
        Sheets("Output").Activate
        Exit Sub
    End If
NotAnOption:
Loop
End Sub

Thanks a lot for your help, I was start getting despair.
This file is good by not going over the budget.
Still there are few things that it doesn’t do.
1. Each list on the output should contain minimum 11 items, maximum 15 (at this file all random lists are 19 items)
2. Each list should contain minimum items for each category, all headers marked in red on my file (theater -1, salon -3, kitchen -4, garden -1). To complete the list (11-15 items) it could be any item of any category as headers mark in black on my file
I’ll really appreciate any help to solve it, at any way.

Is this any better?

You have been very very helpful.

Even though it has some bugs (not always it chooses the correct amount of items for each category) I’ll be able to work with it. I’ll create a feedback formula to make sure each list is ok.
I just want to ask about some things you did so I can learn and understand.
1. Can we make the results to be on one raw or column? (as in my file)
2. What is the usage of the random number column on “data” sheet?
3. Will it work if I’ll add more items to the list? If not, please tell me what I need to change at the VBA code. (There should be about 400 items, I’m not sure yet).

Thanks

The random number column is there to enable a randomisation of the list on every run through the loop. The top 11-15 items are then taken and matched against criteria for total cost and minimum numbers per category. If the code is giving you the wrong numbers in a category then I haven't fully understood what you want. It is set to give a minimum with the code...

    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Theater") < 1 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Salon") < 3 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Kitchen") < 4 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Garden") < 1 Then GoTo NotAnOption

Should it be looking for a maximum as well?

You can add as many items to the list as you wish. Just make sure that you copy the random number in column E down alongside your new entries to make sure that they get included in the randomisation.

Hope this helps.

Hello,

About 2 weeks ago Martin (mrice) helped me a lot to write macro that creates random list.
I work on the file and it's almost exactly what I need...
The issue that I have now is that I need each random lists created by macro to be on a single row.
I attached the file to describe what I need
Sheet 'Data' is data entered manually
Sheet 'Output' is the output results created by mrice
Sheet 'Book 3' is how I need the results to be.

I don’t have to work on the same file. It also fine to create new macro/function to transfer data from 'Output' sheet to 'Book 3'.

Thanks

Try this variation on the macro. You will need to create a sheet called Output2

Sub Test()
Sheets("Output").Cells.Clear
Sheets("Output2").Cells.Clear

Do
    ItemNumber = 11 + Int((5 * Rnd()))
    
    Sheets("Data").Cells(1, 1).CurrentRegion.Sort Header:=xlYes, key1:=Sheets("Data").Cells(2, 5)
    If Application.Sum(Sheets("Data").Range("C2:C" & ItemNumber + 1)) > 100000 Then GoTo NotAnOption
    If Application.Sum(Sheets("Data").Range("C2:C" & ItemNumber + 1)) < 60000 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Theater") < 1 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Salon") < 3 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Kitchen") < 4 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Garden") < 1 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Theater") > 2 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Salon") > 5 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Kitchen") > 7 Then GoTo NotAnOption
    If Application.CountIf(Sheets("Data").Range("D2:D" & ItemNumber + 1), "Garden") > 5 Then GoTo NotAnOption

    
    
    Sheets("Data").Range("A2:D" & ItemNumber + 1).Copy Destination:=Sheets("Output").Cells(65536, 1).End(xlUp).Offset(2, 0)
    Sheets("Output").Cells(65536, 1).End(xlUp).CurrentRegion.Sort Header:=xlNo, key1:=Sheets("Output").Cells(65536, 1).End(xlUp).End(xlToRight)
    For N = Sheets("Output").Cells(65536, 1).End(xlUp).End(xlUp).Row To Sheets("Output").Cells(65536, 1).End(xlUp).Row
        For M = 1 To 4
            If N = Sheets("Output").Cells(65536, 1).End(xlUp).End(xlUp).Row And M = 1 Then
                Sheets("Output").Cells(N, M).Copy Destination:=Sheets("Output2").Cells(65536, 1).End(xlUp).Offset(1, 0)
            Else
                Sheets("Output").Cells(N, M).Copy Destination:=Sheets("Output2").Cells(65536, 1).End(xlUp).End(xlToRight).End(xlToRight).End(xlToLeft).Offset(0, 1)
            End If
        
        Next M
    Next N
    Counter = Counter + 1
    If Counter = Sheets("Data").Range("G2") Then
        Sheets("Output").Activate
        Exit Sub
    End If
NotAnOption:
Loop
End Sub

Work just fine, as I need it!

You helped me a lot! Thanks