Including duplicates

Question

My code finds all the values in (Column A, Sheet 1) that match with the values in (Column A, sheet 2). Then, it copies the entire row of the matched value to a new sheet.

My problem is that sometimes, right below a 'matching' value in sheet1 will be a duplicate matching value. Currently my code is skipping, and not copying these rows over to the new sheet.

Thanks.

Sub matchData()


    Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
    Dim m As Variant, cDest As Range, c As Range
    
    Set wb = Workbooks("A")
    Set wsA = wb.Sheets("1")
    Set wsB = wb.Sheets("2")
    Set wsC = wb.Sheets("3")
    
    Set cDest = wsC.Range("A2") 'start pasting here
    
    For Each c In wsA.Range("D1:D" & wsA.Cells(Rows.Count, "D").End(xlUp).Row).Cells
        m = Application.Match(c.Value, wsB.Columns("A"), 0) 'Match is faster than Find
        If Not IsError(m) Then             'got a match?
            wsB.Rows(m).Copy cDest         'copy matched row
            Set cDest = cDest.Offset(1, 0) 'next paste row
        End If
    Next c
End Sub

Answer 1

If you have duplicates in your lookup range then Match/Find get slower, so a dictionary-based approach can often be better:

Option Explicit

Sub MatchDataWithDups()

    Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
    Dim k, cDest As Range, c As Range, cK As Range
    Dim map As Object
    
    Set wb = Workbooks("A")
    Set wsA = wb.Sheets("1")
    Set wsB = wb.Sheets("2")
    Set wsC = wb.Sheets("3")
    
    'get a Dictionary mapping unique values to their respective cells on wsB
    Set map = RowMap(wsB.Range("A1:A" & wsB.Cells(Rows.Count, "A").End(xlUp).Row))
    Set cDest = wsC.Range("A2") 'start pasting here
    
    For Each c In wsA.Range("D1:D" & wsA.Cells(wsA.Rows.Count, "D").End(xlUp).Row).Cells
        k = c.Value
        If Len(k) > 0 Then
            If map.Exists(k) Then                  'matching value found?
                For Each cK In map(k).Cells        'loop the matched cell(s)
                    cK.EntireRow.Copy cDest        'copy the row
                    Set cDest = cDest.Offset(1, 0) 'next paste row
                Next cK
            End If
        End If
    Next c
End Sub

'Map all unique values in range `rngColumn` to
' a union'ed range of cells where they occur
Function RowMap(rngColumn As Range)
    Dim dict As Object, k, arr, i As Long
    Set dict = CreateObject("scripting.dictionary")
    arr = rngColumn.Value 'read range to array
    
    For i = 1 To UBound(arr, 1) 'loop over array
        k = arr(i, 1)
        If Not dict.Exists(k) Then
            dict.Add k, rngColumn.Cells(i) 'new key
        Else
            'existing key - add another cell
            Set dict(k) = Application.Union(dict(k), rngColumn.Cells(i))
        End If
    Next i
    Set RowMap = dict
End Function