Solved (Excel VBA) Copying unique rows from 1 sheet to another

August 23, 2018 at 01:15:58
Specs: Windows 8
Hi there,

I have some code that is designed to copy 70 rows in total from sheet 1 to sheet 2 based on certain criteria. The code copies across duplicate rows though and I'm unable to figure out how to modify my code to copy across only unique rows.

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)
        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

Any help would be greatly appreciated as I'm not that great at VBA(Haven't been using it long)


Regards,


Matt


message edited by Orkzy


See More: (Excel VBA) Copying unique rows from 1 sheet to another

Reply ↓  Report •

#1
August 24, 2018 at 10:07:57
✔ Best Answer
One possible solution is to create an array of random Row numbers and then loop through that array to do the actual row extractions. Each time a random row number is chosen by the code, you would loop through the existing elements to see if that number already exists. If is doesn't, you append it to the array. If it does, you bounce back up and have the code create a new random number, check that one, etc.

My Response #3 in this thread shows one example of how to create that array of unique Row numbers.

https://www.computing.net/answers/o...

Obviously, since you have criteria to check first, it's a bit more complicated than just creating a list of random numbers between 1 and some maximum number, but the concept is the same. Once you have determined a row number to add based on your criteria, you check to see if it exists. As far as I know, you can't "search" an array for a specific value, you have to loop through the array, checking each element. That slows things down a bit, especially as the list of row numbers gets longer and longer.

I hope that helps.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#2
August 25, 2018 at 08:55:37
Thanks DerbyDad03 for your help. Greatly appreciated. I haven't had chance to test your solution but it seems really near what I'm currently using which works now as well so i'd love to test your solution and then at least I know there's multiple ways to solve my problem.

I can get some more practice at creating random arrays for future work as well.

Regards,

Matt


Reply ↓  Report •
Related Solutions


Ask Question