Trouble copying duplicated values to a new sheet

user_18305410 0
Viewed 41

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.

vba excel
2 Answers

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.

user_146087500

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
user_98140690
Related