Excel VBA: Copying across unique rows from one sheet to another

Question

I'm trying to copy across 70 rows randomly selected based on certain criteria across to another sheet but ensuring only 70 unique rows exist in the second sheet once copied across.

My below code copies over the 70 rows correctly as per the required criteria but it's also copying across duplicate rows as there's no logic to select another row if there's a duplicate value in the array.

Any help on modifying the code to select another row if the row already exists in the array would be greatly appreciated.

I think I need to store the random selected rows and then check that the next selected row is not in that array already else select another row?

Sub MattWilliams()

    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim rng As Range
    Dim keyArr, nRowsArr

    Set rawDataWs = Worksheets("Master")
    Set randomSampleWs = Worksheets("Checks")

    randomSampleWs.UsedRange.ClearContents

    'EDIT: dynamic range in ColA
    Set rng = rawDataWs.Range("AT9:AT" & rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)

    Set map = RowMap(rng)

    keyArr = Array("ALS", "Customer") '<== keywords
    nRowsArr = Array(65, 5) '<== # of random rows

    Debug.Print "Key", "#", "Row#"
    For i = LBound(keyArr) To UBound(keyArr) 'loops through lower and upper bound of the 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)

            If rawDataWs.Range("S" & col(rand)).Value = "FTF" Then

                 rawDataWs.Rows(col(rand)).Copy _
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    If col.Count = 0 Then
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
        c = c - 1
    End If

Else
    c = c - 1


            End If
                'col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)

                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

If you need any more information please let me know

Regards,

Matt

Answer 1

You need to use an array of unique random numbers to assure that they are not the same. Unique random numbers function can be found here. (drop a upvote if useful)

Sub MattWilliams()

    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim rng As Range
    Dim keyArr, nRowsArr
    Dim samplepattern() As Long ' dim the samplepattern

    Set rawDataWs = Worksheets("Master")
    Set randomSampleWs = Worksheets("Checks")

    randomSampleWs.UsedRange.ClearContents

    'EDIT: dynamic range in ColA
    Set rng = rawDataWs.Range("AT9:AT" & rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)

    Set map = RowMap(rng)

    keyArr = Array("ALS", "Customer") '<== keywords
    nRowsArr = Array(65, 5) '<== # of random rows

    Debug.Print "Key", "#", "Row#"
    For i = LBound(keyArr) To UBound(keyArr) 'loops through lower and upper bound of the KeyArr
        If map.exists(keyArr(i)) Then

            Set col = map(keyArr(i))
            n = nRowsArr(i)
            '''''''''''''''''''''''''''''''''''''''''
            'solution starts here
            samplepattern = UniuqeRandom(1, col.Count,n) 'see link "here"

            For c = 1 To n
                Debug.Print keyArr(i), samplepattern(n), col(rand)

            If rawDataWs.Range("S" & col(samplepattern(n))).Value = "FTF" Then

                 rawDataWs.Rows(col(samplepattern(n))).Copy _
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        ' end of solution
        '''''''''''''''''''''''''''''''''''''''
    If col.Count = 0 Then
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
        c = c - 1
    End If

Else
    c = c - 1


            End If
                'col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)

                End If
            Next c

        Else
            Debug.Print "No rows for " & keyArr(i)
        End If
    Next i
End Sub

So basically you get a set of random numbers, all unique before hand. Then you loop through your set and copy all rownumbers that are contained in that set.

example: samplepattern() = [2,3,7,17] are 4 unique random numbers between 1 and 20. Now I go ahead and loop through all members of samplepattern() and copy the rows(samplepattern(i)). So i copy row number 2,3,7 and 17.