Random generate multiple names from a list with exclusions & sorting

[camspy]

Here's my table:

Here's also the sheet:

test.xlsx
	A	B	C	D	E	F
1	Names	Rank	Exclude	simple	sorted	sorted+excluded
2	Abigail	65	Olivia
3	Sophia	25	Mila
4	Amelia	30
5	Elizabeth	80	Isabella,Sophia,Amelia
6	Ava	15	Gianna,Emma
7	Isabella	35	Luna
8	Gianna	60
9	Harper	50
10	Mila	100	Sofia
11	Olivia	5
12	Charlotte	20
13	Evelyn	45	Camila,Ava,Abigail
14	Avery	95	Charlotte
15	Emily	90	Evelyn,Mia
16	Ella	75
17	Sofia	85	Avery,Emily
18	Mia	40	Elizabeth,Ella
19	Camila	55
20	Emma	10	Harper
21	Luna	70
Sheet1

I need to generate 10 random names (delimited), without duplicates, in each cell of columns D, E and F, the rules are below:

1. In column D: just the list of 10 randomly generated and delimited names, without dupes;
2. In column E: the same as in column D, but the results should be sorted by ranks taken from B2:B21, from high to low;
3. In column F: the same as in column E, but the results will have per-row exclusions, listed in column C.

Each result should contain 10 names, and visually should look like this: Sophia,Amelia,Isabella,Mia,Evelyn,Harper,Camila,Gianna,Abigail,Luna

I have tried many of the solutions with RANDARRAY and RANDBETWEEN formulas found on the internet, but didn't succeed myself.

Maybe it's not even possible to have it working using just formulas?
Maybe VBA is required?

Any help is appreciated.
Thanks in advance.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[camspy]

You're welcome & thanks for the feedback.

Hi Fluff,
I've tested your formulas with the field data with hundreds of rows.
Particularly I've tested the formula from col F.

I counted the frequency of appearance of the names in the generated column.
The thing is that some names get generated 30+ times across the sheet, while the others - 0 times.

Is there a way of having distribution of the names more smooth/fair?

Perhaps formulas won't be able to help with that and I'm afraid, that VBA may be needed.

I also thought, that logically, maybe the names with higher rank could have some better distribution across the sheet, comparing to names with lower rank.

 

[Fluff]

Whilst I would expect some variation in the number of times the names are pulled, I'm surprised it's that much.
However there is no way (that I know of) to change that as I suspect that all the rand functions work the same way. I also doubt that VBA would be any better.

 

[camspy]

Whilst I would expect some variation in the number of times the names are pulled, I'm surprised it's that much.
However there is no way (that I know of) to change that as I suspect that all the rand functions work the same way. I also doubt that VBA would be any better.

What if using an additional helper column with some sort of extra data to make the results more steady?

 

[Fluff]

I've no idea how that would work. At the end of the day randarray is random, which is what you wanted.

 

[camspy]

I've no idea how that would work. At the end of the day randarray is random, which is what you wanted.

Yes sure. I just thought that, randomness will follow the probability theory, meaning that each name should more or less get similar distribution

 

[Fluff]

I would expect the same thing, but the results for col F will be skewed as you are excluding some names on some rows.

 

[camspy]

In my tests I was excluding just 1 name for each set. So the results won't contain own name.

 

[BSALV]

i made perhaps an error, but i have no 10 exclusive names, max. 8

Sub list10()
     Dim arr(), Excl(), Result(1 To 10000, 1 To 4), iRes

     a = Sheets("blad1").ListObjects("TBL_Namen").DataBodyRange     'the names
     t = Timer                                                  'start chronometer

     For iRes = 1 To UBound(Result)                             'loop for x good combinations
          s = "": ptr = 1                                       'start with no exclusives and pointer 1
          rand = Application.Transpose(WorksheetFunction.RandArray(UBound(a)))     'as many random numbers as names
          ReDim arr(1 To 10, 1 To 2): ReDim Excl(1 To 10, 1 To 2)     'reset tempory arrays
          For i = 1 To UBound(a)                                'make as many loops as there are names
               r = Application.Match(WorksheetFunction.Small(rand, i), rand, 0)     'row of the i-smallest value for Rand
               If i <= UBound(arr) Then arr(i, 1) = a(r, 1): arr(i, 2) = a(r, 2)     'for the first 2 columns there are no exclusives, so write without checking until enough names found

               m = "": If Len(s) > 0 Then m = Application.Match(a(r, 1), Split(s, ","), 0)
               If Not IsNumeric(m) Then
                    b = True
                    If Len(a(r, 3)) > 0 Then
                         sp = Split(a(r, 3), ",")
                         arr1 = Application.Transpose(Application.Index(arr, 0, 1))
                         For j = 0 To UBound(sp)
                              r1 = Application.Match(sp(j), arr1, 0)
                              If IsNumeric(r1) Then b = False: Exit For
                         Next
                         If b Then
                              Excl(ptr, 1) = a(r, 1): Excl(ptr, 2) = a(r, 2): s = s & "," & a(r, 3) & "," & a(r, 1): ptr = ptr + 1
                         Else
     'MsgBox Join(arr1, ",") & vbLf & a(r, 1) & vbLf & a(r, 3)
                         End If
                         If ptr > UBound(Excl) Then Exit For
                    End If
               End If
          Next
          If Excl(UBound(Excl), 1) = "" Then Excl(UBound(Excl), 1) = "ERROR" & ptr - 1: Excl(UBound(Excl), 2) = -1

          Result(iRes, 1) = Join(Application.Transpose(Application.Index(arr, 0, 1)), ",")
          arr1 = Application.Sort(arr, 2, -1)
          Result(iRes, 2) = Join(Application.Transpose(Application.Index(arr1, 0, 1)), ",")
          Arr2 = Application.Sort(Excl, 2, -1)
          Result(iRes, 3) = Join(Application.Transpose(Application.Index(Arr2, 0, 1)), ",")
          Result(iRes, 4) = s
          DoEvents
     Next

     With Range("E2")
          .Resize(10000, 4).ClearContents
          .Resize(UBound(Result), UBound(Result, 2)).Value = Result
     End With
     MsgBox Timer - t
End Sub

 

[camspy]

i made perhaps an error, but i have no 10 exclusive names, max. 8

Sub list10()
     Dim arr(), Excl(), Result(1 To 10000, 1 To 4), iRes

     a = Sheets("blad1").ListObjects("TBL_Namen").DataBodyRange     'the names
     t = Timer                                                  'start chronometer

     For iRes = 1 To UBound(Result)                             'loop for x good combinations
          s = "": ptr = 1                                       'start with no exclusives and pointer 1
          rand = Application.Transpose(WorksheetFunction.RandArray(UBound(a)))     'as many random numbers as names
          ReDim arr(1 To 10, 1 To 2): ReDim Excl(1 To 10, 1 To 2)     'reset tempory arrays
          For i = 1 To UBound(a)                                'make as many loops as there are names
               r = Application.Match(WorksheetFunction.Small(rand, i), rand, 0)     'row of the i-smallest value for Rand
               If i <= UBound(arr) Then arr(i, 1) = a(r, 1): arr(i, 2) = a(r, 2)     'for the first 2 columns there are no exclusives, so write without checking until enough names found

               m = "": If Len(s) > 0 Then m = Application.Match(a(r, 1), Split(s, ","), 0)
               If Not IsNumeric(m) Then
                    b = True
                    If Len(a(r, 3)) > 0 Then
                         sp = Split(a(r, 3), ",")
                         arr1 = Application.Transpose(Application.Index(arr, 0, 1))
                         For j = 0 To UBound(sp)
                              r1 = Application.Match(sp(j), arr1, 0)
                              If IsNumeric(r1) Then b = False: Exit For
                         Next
                         If b Then
                              Excl(ptr, 1) = a(r, 1): Excl(ptr, 2) = a(r, 2): s = s & "," & a(r, 3) & "," & a(r, 1): ptr = ptr + 1
                         Else
     'MsgBox Join(arr1, ",") & vbLf & a(r, 1) & vbLf & a(r, 3)
                         End If
                         If ptr > UBound(Excl) Then Exit For
                    End If
               End If
          Next
          If Excl(UBound(Excl), 1) = "" Then Excl(UBound(Excl), 1) = "ERROR" & ptr - 1: Excl(UBound(Excl), 2) = -1

          Result(iRes, 1) = Join(Application.Transpose(Application.Index(arr, 0, 1)), ",")
          arr1 = Application.Sort(arr, 2, -1)
          Result(iRes, 2) = Join(Application.Transpose(Application.Index(arr1, 0, 1)), ",")
          Arr2 = Application.Sort(Excl, 2, -1)
          Result(iRes, 3) = Join(Application.Transpose(Application.Index(Arr2, 0, 1)), ",")
          Result(iRes, 4) = s
          DoEvents
     Next

     With Range("E2")
          .Resize(10000, 4).ClearContents
          .Resize(UBound(Result), UBound(Result, 2)).Value = Result
     End With
     MsgBox Timer - t
End Sub

Hi Bsalv, thank you for your help.
Could you explain how to run it and what results will it bring?
Is your code related to my later post? Random generate multiple names from a list with exclusions & sorting