vba how to select a set of rows based on multiple column - excel

Question

Please help
I am trying to perform the following:
I have an excel file 'A' with 50000 rows.
I am creating another excel 'B' with 150 rows.
The 150 rows are picked from file 'A'.
The row selection criteria is based on values of 5 different columns as this set
First I want to make sure I select the rows with all different combination of these 5 columns
If I run out of combinations then I can pick combination which are repeated as have to reach the 150
What I have achieved till now is selecting 150 random rows from excel A and pasted in excel B
records = 150
With DataWs
SourceLastRow = .Cells(.Rows.count, "B").End(xlUp).Row
.Rows(1).Copy DestinationWs.Cells(DestLastRow, "A")
ar = RandomNumber(2, SourceLastRow, Records)
For r = 2 To UBound(ar)
DestLastRow = DestLastRow + 1
.Rows(ar(r)).Copy DestinationWs.Cells(DestLastRow, "A")
Next r
End With
Function RandomNumber(Bottom As Long, Top As Long, Amount As Long) As Variant
Dim i As Long, r As Long, temp As Long
ReDim iArr(Bottom To Top) As Long
For i = Bottom To Top: iArr(i) = i: Next i
For i = 1 To Amount
r = Int(Rnd() * (Top - Bottom + 1 - (i - 1))) _
+ (Bottom + (i - 1))
temp = iArr(r): iArr(r) = iArr(Bottom + i - 1): _
iArr(Bottom + i - 1) = temp
Next i
ReDim Preserve iArr(Bottom To Bottom + Amount - 1)
RandomNumber = iArr
End Function

Answer 1

This is maybe a bit complex but worked for me:
Sub PickRows()
Const COPY_ROWS As Long = 150
Dim dict As Object, data, DataWS As Worksheet, DestWS As Worksheet
Dim numCopied As Long, r As Long, k As String, destRow As Long
Dim combo As Long, keys, col As Collection, theRow As Long, t
Set DataWS = Sheet2 'for example
Set DestWS = Sheet3 'for example
'get the source data (at least the part with the key columns) in an array
data = DataWS.Range("A1:E" & DataWS.Cells(DataWS.Rows.Count, "B").End(xlUp).Row).Value
Set dict = CreateObject("scripting.dictionary")
'fill the dictionary - keys are combined 5 columns, values are collection
' containing the row number for each source row with that key
For r = 2 To UBound(data, 1)
k = RowKey(data, r, Array(1, 2, 3, 4, 5)) 'combination of the 5 columns
If Not dict.exists(k) Then
dict.Add k, New Collection 'new combination?
End If
dict(k).Add r
Next r
numCopied = 0
combo = 0
destRow = 2
'loop over the various key column combinations and pick a row from each
' keep looping until we've copied enough rows
Do While numCopied < COPY_ROWS
'see here for why the extra ()
'https://stackoverflow.com/questions/26585884/runtime-error-with-dictionary-when-using-late-binding-but-not-early-binding
Set col = dict.Items()(combo) 'a collection of all rows for this particular key
theRow = RemoveRandom(col)
'edit line below to copy more columns (eg change 5 to 10)
DataWS.Cells(theRow, 1).Resize(1, 5).Copy DestWS.Cells(destRow, 1)
destRow = destRow + 1 'next destination row
If col.Count = 0 Then dict.Remove dict.keys()(combo) 'remove if no more rows for this key
If dict.Count = 0 Then Exit Do 'run out of any rows to pick? (should not happen...)
combo = combo + 1
If combo >= dict.Count Then combo = 0 'start looping again
numCopied = numCopied + 1
Loop
End Sub
'Create a composite key from columns in arrKeyCols
Function RowKey(data, rowNum, arrKeyCols) As String
Dim rv, i, sep
For i = LBound(arrKeyCols) To UBound(arrKeyCols)
rv = rv & sep & data(rowNum, arrKeyCols(i))
sep = "~~"
Next i
RowKey = rv
End Function
'select a random item from a collection, remove it, and return the value
Function RemoveRandom(col As Collection)
Dim rv, num As Long
num = Application.RandBetween(1, col.Count)
RemoveRandom = col(num)
col.Remove num
End Function