Weighted random name selector from an external workbook

Question

I'm new to VBA but have some coding background. The below must be done through Excel.

Objective: I am running some Q&A sessions with a variable length of the list of attendees which will be stored in a separate register (external xlsx file). I need a list of names that are to be selected at random, but the names will have weighting to them so that some names are more likely to be selected than others. At the moment, I don't mind if the same name comes up again and again. The table of data will always be an external file, and the data cannot be printed to the main worksheet due to GDPR.

Example snippet of the data that will be read, this is NOT exhaustive:

ID	Name	Weighting
1	Person 1	3
2	Person 2	1
3	Person 3	2
4	Person 4	5
5	Person 5	1

So Person 4 will be 5 times more likely to be picked than Person 5, for example.

I've been going around in circles so far. I thought adding the data to an array and then looping through that array to find a weighting,array1(3,i) that is greater than 1, then grabbing the name to the left array1(2,i) and adding it again to the end of the array would work.

However, I have since found out you cannot increase the first dimension of an array dynamically in VBA.

I am initially declaring my array with array1 = wb.Worksheet(1).ListObjects("Table1").DataBodyRange.Value, where wb is the open workbook captured through GetOpenFilename().

Any idea what I can try? I would print my code, however my PC just reset and I lost the last save state, but can attempt a rewrite if it would be useful?

I have followed various examples/tutorials online but I think this exact scenario doesn't seem to be covered, and with my lack of VBA knowledge I'm at a loose end.

Answer 1

This solution assumes you are reading a file, and the comments relate to that action, as this example is using a worksheet. It loads up all names the appropriate number of times into a collection. You then need to generate a random number to choose the appropriate name.

Sub testit()
        Dim lott As Collection
        Set lott = New Collection
        Dim idx As Long, idxMax As Long, idxCur As Long
        idx = 1 'read the first record
        Do While Cells(idx, 2) <> "" ' process file until end
                If Cells(idx, 2) > idxMax Then idxMax = Cells(idx, 2) ' find the highest weight
                lott.Add Cells(idx, 1) ' put the name into the collection
                idx = idx + 1 ' read the next record
        Loop
        idxCur = 2
        Do Until idxCur > idxMax  ' cycle through the file as many times as necessary
                idx = 1 ' close and reopen the file
                Do While Cells(idx, 2) <> "" ' process file until end
                        If Cells(idx, 2) >= idxCur Then
                                lott.Add Cells(idx, 1) 'put the name into the collection again
                        End If
                        idx = idx + 1
                Loop
                idxCur = idxCur + 1
        Loop
        For idx = 1 To lott.Count
                Debug.Print lott.Item(idx)
        Next
        Randomize
        idx = lott.Count * Rnd + 1
        Debug.Print "got ", lott.Item(idx)
End Sub

Answer 2

Since the selection is random the order of the names in the array does not matter.

Option Explicit

Sub test()

   Randomize
   MsgBox Pick(wb.Sheets(1).Range("A1:C6"))
   
End Sub

Function Pick(rng As Range)
   Dim ar, i As Long, j As Long, n As Long
   Dim lastrow As Long
   With rng
       lastrow = .Rows.Count
       n = WorksheetFunction.Sum(rng.Columns(3))
       ReDim ar(1 To n)
       n = 0
       For i = 2 To lastrow
           For j = 1 To .Cells(i, 3)
              n = n + 1
              ar(n) = .Cells(i, 2)
           Next
       Next
   End With
   i = 1 + Int(Rnd * n)
   Pick = ar(i)
End Function

Answer 3

Unique Random Names With Weighting

Main

Sub RandomizeNames()
    
    Const SAMPLE_SIZE As Long = 10
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData(), wData(), rCount As Long, dCount As Long
    
    With wb.Worksheets(1).ListObjects("Table1")
        sData = .ListColumns("Name").DataBodyRange.Value
        With .ListColumns("Weighting").DataBodyRange
            wData = .Value
            rCount = .Rows.Count
            dCount = Application.Sum(.Cells)
        End With
    End With
    
    Dim dArr(): ReDim dArr(1 To dCount)
    
    Dim r As Long, w As Long, d As Long
    
    For r = 1 To rCount
        For w = 1 To wData(r, 1)
            d = d + 1
            dArr(d) = sData(r, 1)
        Next w
    Next r
    
    Debug.Print "------" & vbLf & "Before Shuffle" & vbLf & "------" & vbLf _
        & Join(dArr, ",")
    
    ShuffleArray dArr
    
    Debug.Print "------" & vbLf & "After Shuffle" & vbLf & "------" & vbLf _
        & Join(dArr, ",")
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    For d = 1 To SAMPLE_SIZE
        dict(dArr(d)) = Empty
    Next d
    
    Do While dict.Count < SAMPLE_SIZE
        dict(dArr(d)) = Empty
        d = d + 1
    Loop
    
    Debug.Print "------" & vbLf & "Result" & vbLf & "------" & vbLf _
        & Join(dict.keys, vbLf)
    
End Sub

Help

Sub ShuffleArray(ByRef Arr As Variant)
    
    Dim LB As Long: LB = LBound(Arr)
    
    Dim Temp As Variant, i As Long, j As Long
    
    For i = UBound(Arr) To LB + 1 Step -1
        j = Int((i - LB + 1) * Rnd + LB)
        Temp = Arr(i): Arr(i) = Arr(j): Arr(j) = Temp
    Next i

End Sub

Result

------
Before Shuffle
------
Olivia,Olivia,Olivia,Olivia,Olivia,Charlotte,Charlotte,Charlotte,Charlotte,Charlotte,Gianna,Gianna,Harper,Harper,...
------
After Shuffle
------
Eleanor,Charlotte,Isabella,Isabella,Emma,Amelia,Sofia,Olivia,Gianna,Camila,Isabella,Sophia,Mia,Mia,Emma,Luna,...
------
Result
------
Eleanor
Charlotte
Isabella
Emma
Amelia
Sofia
Olivia
Gianna
Camila
Sophia