Option Explicit
' change this to adjust the number of samples of each item
Const iSamples As Integer = 21
Sub chooseRandom()
' create a scripting dictionary to hold concatenated results for each unique ID
Dim dictCodes As Scripting.Dictionary: Set dictCodes = New Scripting.Dictionary
' create another dictionary to hold arrays of unique random numbers
Dim dictRands As Scripting.Dictionary
' create array to hold chosen items
Dim arrResults: ReDim arrResults(1 To 2, 1 To 1)
Dim iResCount As Integer
' create other variables required
Dim strID As String
' pull unconnected data into dictionary by choosing only even rows (also ignores header row)
Dim cl As Range
For Each cl In Sheet1.Columns(1).SpecialCells(xlCellTypeConstants)
If cl.Row / 2 = cl.Row \ 2 Then
strID = cl.Value
dictCodes(strID) = dictCodes(strID) & cl.Offset(0, 1) & "|"
End If
Next cl
' process dictionary
Dim k1, k2, s
For Each k1 In dictCodes.Keys
' split dictionary item into constituent parts
s = Split(dictCodes(k1), "|")
' get integers that reflect position in dictionary
Set dictRands = dictUniqueRands(UBound(s))
' pass relevant item to results array
For Each k2 In dictRands.Keys
iResCount = iResCount + 1
ReDim Preserve arrResults(1 To 2, 1 To iResCount) ' only last dimension of array can be resized when preserving data. Must transpose later
arrResults(1, iResCount) = k1
arrResults(2, iResCount) = s(k2)
Next k2
Next k1
' pass results array to new workbook. Can change to any other location and avoid creating new workbook
Dim wb As Workbook
Set wb = Workbooks.Add
wb.Sheets(1).Range("A1").Resize(UBound(arrResults, 2) - LBound(arrResults, 2) + 1, UBound(arrResults, 1) - LBound(arrResults, 1) + 1).Value = Application.Transpose(arrResults)
End Sub
Function dictUniqueRands(iMax As Integer) As Scripting.Dictionary
' creates a set of numbers chosen at random but not repeated. Because this is to work with a base-0 dictionary we include 0 but exclude the dictionary size
Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim i As Integer
Do
i = WorksheetFunction.RandBetween(0, iMax - 1)
If Not d.Exists(i) Then d(i) = i
Loop Until d.Count = WorksheetFunction.Min(iMax, iSamples) ' needs to consider case where less data items than samples requested
Set dictUniqueRands = d
End Function
. To put it into an example:
