VBA/Macro to copy random rows based on multiple conditions - vba

Question

I need help to be able to get random rows from another workbook with specific conditions:
If i click a button/run a macro, I should get something like this :
4 random rows for all rows that has "AU"
1 random row for all rows that has "FJ"
1 random row for all rows that has "NC"
3 random rows for all rows that has "NZ"
1 random row for all rows that has "SG12"
ALL FROM Raw Data_Park Sampling.xlsx "Sheet1" sheet and paste it to Park Sampling Tool.xlsm "Random Sample" sheet.
All should happen in one click.
Below is the whole code i got.
Sub MAINx1()
'Delete current random sample
Sheets("Random Sample").Select
Cells.Select
Range("C14").Activate
Selection.Delete Shift:=xlUp
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, c As Long, rand, col
Dim keyArr, nRowsArr
Dim rng As Range
Set rawDataWs = Workbooks("Raw Data_Park Sampling.xlsx").Worksheets("Sheet1")
Set randomSampleWs = Workbooks("Park Sampling Tool.xlsm").Worksheets("Random Sample")
randomSampleWs.UsedRange.ClearContents
'Set map = RowMap(rawDataWs.Range("A2:A923"))
Set rng = rawDataWs.Range("A2:A" & _
rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng)
keyArr = Array("AU", "FJ", "NC", "NZ", "SG12", "ID", "PH26", "PH24", "TH", "ZA", "JP", "MY", "PH", "SG", "VN") '<== keywords
nRowsArr = Array(4, 1, 1, 3, 1, 3, 3, 1, 3, 4, 2, 3, 1, 3, 2) '<== # of random rows
'Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For c = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
'Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next c
Else
'Debug.Print "No rows for " & keyArr(i)
End If
Next i
MsgBox "Random Sample: Per Day Successfully Generated!"
End Sub
'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
Dim dict, c As Range, k
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
k = Trim(c.value)
If Len(k) > 0 Then
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c.Row
End If
Next c
Set RowMap = dict
End Function

Answer 1

Simplified from your original code to focus on the approach:
Sub MAIN()
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
Dim map, i As Long, n As Long, c As Long, rand, col
Dim keyArr, nRowsArr, rng
Set rawDataWs = Worksheets("Sheet1")
Set randomSampleWs = Worksheets("Sheet2")
randomSampleWs.UsedRange.ClearContents
'EDIT: dynamic range in ColA
Set rng = rawDataWs.Range("A2:A" & _
rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)
Set map = RowMap(rng)
keyArr = Array("AU", "FJ", "NC", "NZ", "SG12") '<== keywords
nRowsArr = Array(4, 1, 1, 3, 10) '<== # of random rows
Debug.Print "Key", "#", "Row#"
For i = LBound(keyArr) To UBound(keyArr)
If map.exists(keyArr(i)) Then
Set col = map(keyArr(i))
n = nRowsArr(i)
For c = 1 To n
'select a random member of the collection
rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
Debug.Print keyArr(i), rand, col(rand)
rawDataWs.Rows(col(rand)).Copy _
randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
col.Remove rand 'remove the "used" row
If col.Count = 0 Then
If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
Exit For
End If
Next c
Else
Debug.Print "No rows for " & keyArr(i)
End If
Next i
End Sub
'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
Dim dict, c As Range, k
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
k = Trim(c.Value)
If Len(k) > 0 Then
If Not dict.exists(k) Then dict.Add k, New Collection
dict(k).Add c.Row
End If
Next c
Set RowMap = dict
End Function

Answer 2

Not sure if I can follow the logic as it is too complex for me. If you don't mind, I worked out an alternative code.
EDIT:
I was assuming you can modify the code to get the source/destination. I tested this in excel 2013 and assuming:
the code is running from another work book (not source/destination).
Key is in the first column.
you will modify the oKey and oCnt as per your requirement.
Dim oWS As Worksheet
Dim oWSSrc As Worksheet
Dim oWBSrc As Workbook
Dim oWBDest As Workbook
Dim oRng As Range
Dim oStart As Range
Dim oLast As Range
Dim oMatch As Range
Dim oDest As Range
Dim oKey As Variant
Dim oCnt As Variant
Dim iCnt As Integer
Dim iTot As Integer
Dim iMatch As Integer
oKey = Split("AU,FJ,NZ", ",") '<= modify this
oCnt = Split("4,1,3", ",") ' <= modify this
'Open Destination
Set oWBDest = Application.Workbooks.Open("Tool.xlsm")
Set oWS = oWBDest.Sheets.Add
'Open source workbook
Set oWBSrc = Application.Workbooks.Open("Rawdata.xlsx")
Set oWSSrc = oWBSrc.Sheets("Sheet1")
Set oRng = oWSSrc.Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown))
oRng.Copy oWS.Cells(1, 1)
oWBSrc.Close
'assume key
Set oStart = oWS.Cells(1, 1)
Set oRng = oWS.Range(oStart, oStart.End(xlToRight).End(xlDown).Offset(1))
oWBDest.Sheets("Random Sample").UsedRange.Clear
Set oDest = oWBDest.Sheets("Random Sample").Cells(1, 1)
Randomize
'Assign random numbers for sorting
For iCnt = 1 To oRng.Rows.Count - 1 ' last row is a dummy row do not assign
oRng.Cells(iCnt, oRng.Columns.Count + 1) = Rnd()
Next
'sort by key (col1) and random number (last col)
With oWS.Sort
.SortFields.Clear
.SortFields.Add oWS.Columns(1)
.SortFields.Add oWS.Columns(oRng.Columns.Count + 1)
.SetRange oWS.Range(oStart, oStart.End(xlToRight).End(xlDown))
.Apply
End With
For iCnt = LBound(oKey) To UBound(oKey)
'Find the first match
Set oStart = oRng.Find(oKey(iCnt), oRng.Cells(oRng.Rows.Count, 1), xlValues, xlWhole, xlByRows, xlNext)
Set oLast = oStart ' initiliase
If Not oStart Is Nothing Then
'-1 as the first one has been detected
For iMatch = 1 To CInt(oCnt(iCnt)) - 1
Set oMatch = oRng.Find(oKey(iCnt), oLast, xlValues, xlWhole, xlByRows, xlNext)
' Match the same as start exit (means there are not enough row)
If oMatch.Address = oStart.Address Then
Exit For
Else
Set oLast = oMatch
End If
Next
'copy the match to output
Set oStart = oWS.Range(oStart, oLast.Offset(, oRng.Columns.Count - 1))
oStart.Copy oDest
If oDest.Offset(1).Value <> "" Then
Set oDest = oDest.End(xlDown).Offset(1)
Else
Set oDest = oDest.Offset(1)
End If
End If
Next
'Cleaning up
Application.DisplayAlerts = False
oWS.Delete
Application.DisplayAlerts = True
oWBDest.Save
oWBDest.Close