Trouble copying duplicated values to a new sheet - excel

Question

I've been tooling with this code originally provided by #Tim Williams.
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("1")
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).row).Cells
m = Application.Match(c.Value, wsB.Columns("D"), 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
It searches through all the values in a column in Sheet A, finds those matching cells in a column of Sheet B, and finally copies that entire row to Sheet C.
It's working great, but I cant crack how to handle certain cases of duplicates.
If Sheet A has duplicates (ie. one cell contains "test" and the following cell contains "test"). It works great if Sheet B only has one cell that contains "test", as it copies this value over the the new sheet twice.
However, In Sheet B, if the cell containing 'test' is followed by another cell containing 'test', it only copies over the first one, not the one below it as well.
I'm having a hard enough time wrapping my head around even the logic of this, thanks for any input.

Answer 1

You would want to put a second loop inside the first loop, and create something with the logic "For Each Match that I find for this c.Value in Sheet B Column D... Do that copy paste code block"
To find multiple matches of the same value, you can use a FindNext loop. I am not familiar with the Match function and I don't know if its loopable.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
Next c
End Sub
So that above code will handle duplicates on Sheet B, but what to do if there are duplicates on sheet A? I suggest using a dictionary to keep track of c.Value and if it detects a duplicate, skips it.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Dim cVals As Object
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cVals = CreateObject("Scripting.Dictionary")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
If Not cVals.exists(c.Value) Then
cVals.Add c.Value, 0
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
End If
Next c
End Sub
You can see above, each loop checks to see if dictionary cVals already has the current value in the dictionary, and only continues with the code if it doesn't, otherwise moving to the next loop iteration.

Answer 2

A VBA Lookup: Lookup Direction
A Rule of Thumb
When there are two columns, you can lookup in two directions.
If you will be copying all the matches in column B, you should loop through the cells in column B and find matches in column A (see A Quick Fix).
Note that you could write all the unique values from column A to an array of strings and use it as the parameter of the Criteria1 argument of the AutoFilter method to filter the data in column B and copy it in one go. But we're playing around here, aren't we?
If the order of the values in column A matters, and there are duplicates in column B then you cannot easily use Application.Match but you could use a combination of the Find and FindNext methods.
I Wonder...
Why should it copy a found row twice ("It works great..., as it copies this value over to the new sheet twice")?
A Quick Fix
Option Explicit
Sub CopyMatches()
Dim wb As Workbook: Set wb = Workbooks("1")
Dim lws As Worksheet: Set lws = wb.Worksheets("A")
Dim sws As Worksheet: Set sws = wb.Worksheets("B")
Dim dws As Worksheet: Set dws = wb.Worksheets("C")
Dim lrg As Range ' Lookup
Set lrg = lws.Range("A2:A" & lws.Cells(lws.Rows.Count, "A").End(xlUp).Row)
Dim srg As Range ' Source
Set srg = sws.Range("D2:D" & sws.Cells(sws.Rows.Count, "D").End(xlUp).Row)
Dim dCell As Range ' Destination
Set dCell = dws.Range("A2") ' needs to be column 'A' because 'EntireRow'
'dCell.EntireRow.Offset(dws.Rows.Count - dCell.Row + 1).Clear
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(Application.Match(sCell, lrg, 0)) Then
sCell.EntireRow.Copy dCell
Set dCell = dCell.Offset(1)
End If
Next sCell
MsgBox "Data copied.", vbInformation
End Sub