VBA find duplicates from sheet 1 in sheet 2 and if found copy entire row from sheet 1 to bottom of table sheet 2

[jufglanville]

Hi all,

I'm looking to write a macro that looks a two sheets (Sheet1 & Sheet2). These sheets each contain a table of data. I'm hoping to run code that looks down column U in Sheet1 and see if that value exists in column U in Sheet2. If it does I want to copy the corresponding row from Sheet1 and place it at the bottom of Sheet2. Sometimes there are multiple matches of the same value found in Sheet1 and in that instance I would want to copy all rows containing the match and place at the bottom of Sheet2.

I stumbled across this code which I think could be used as a base. It searches my rows and places the value found in column U of Sheet1 next to the matching data in column AL Sheet2. (I want to place the entire row not just the value in column U, and I want to place it at the bottom of the table not next to it). This code also places "No Match" if no match is found. This isn't required in my code.

Sub NoteMatch()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String

    lastRow1 = Sheets("sheet1").Range("U" & Rows.Count).End(xlUp).Row: x = 1
    lastRow2 = Sheets("sheet1").Range("U" & Rows.Count).End(xlUp).Row: x = 1
    
    For sRow = 2 To lastRow1
        tempVal = Sheets("Sheet1").Cells(sRow, "U").Text

        For tRow = 2 To lastRow2
            If Sheets("Sheet2").Cells(tRow, "U") = tempVal Then
                Sheets("Sheet2").Cells(tRow, "AL") = Sheets("Sheet1").Cells(sRow, "U")
            End If
        Next tRow
    Next sRow

Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
    
    
    For lRow = 2 To lastRow2
        match = False
        tempVal = Sheets("Sheet2").Cells(lRow, "U").Text

        For sRow = 2 To lastRow1
            If Sheets("Sheet1").Cells(sRow, "U") = tempVal Then
                match = True
            End If
        Next sRow

        If match = False Then
            Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
        End If
    Next lRow
End Sub

 

[wideboydixon]

Give this a stab:

Public Sub NoteMatch()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim thisRow1 As Long
Dim thisRow2 As Variant
Dim nextRow1 As Long
Dim matchRange As Range

lastRow1 = Sheets("Sheet1").Range("U" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Range("U" & Sheets("Sheet2").Rows.Count).End(xlUp).Row
nextRow1 = lastRow1 + 1

For thisRow1 = 2 To lastRow1
    Set matchRange = Sheets("Sheet2").Range("U2:U" & lastRow2 + 2)
    Do While True
        thisRow2 = Application.Match(Sheets("Sheet1").Cells(thisRow1, "U").Value, matchRange, 0)
        If IsError(thisRow2) Then
            Exit Do
        Else
            matchRange(thisRow2).EntireRow.Copy Destination:=Sheets("Sheet1").Cells(nextRow1, 1)
            nextRow1 = nextRow1 + 1
            Set matchRange = Sheets("Sheet2").Range("U" & matchRange(thisRow2).Row + 1 & ":U" & lastRow2 + 2)
        End If
    Loop
Next thisRow1

End Sub

WBD

 

[jufglanville]

Hi WBD,

I just tried running your code but nothing seemed to happen. None of the data was copied across. I'm not sure if I did something wrong?!

 

[wideboydixon]

Then could you post some sample data? I ran it on a local workbook and rows were copied as expected.

WBD

 

[jufglanville]

Not 100% sure on the best way to upload sample data as I can't use plugins on my computer at work but here are a few lines below, I hope this helps:

Sheet 1:

Column A | Column R | Column U | Column AI
Apr 17 | 8500 | Campbell Construction Group | -1376.24
Apr 17 | 2300 | Archive Holding Account | 0
Apr 17 | 1500 | Aviva Life | 0
Apr 17 | 4593 | B J M Invest | -2109


Sheet 2:

Column A | Column R | Column U | Column AI
Oct 17 | 9000 | Campbell Construction Group | -1222
Oct 17 | 2300 | Campbell Construction Group | 0
Oct 17 | 43665 | Calendar Club Ltd | 121
Oct 17 | 2323 | Camlachie Cooperage | 0


Expected Result:

Sheet 2:

Column A | Column R | Column U | Column AI
Oct 17 | 9000 | Campbell Construction Group | -1222
Oct 17 | 2300 | Campbell Construction Group | 0
Oct 17 | 43665 | Calendar Club Ltd | 121
Oct 17 | 2323 | Camlachie Cooperage | 0
Apr 17 | 8500 | Campbell Construction Group | -1376.24

 

[jufglanville]

I've just tried this on some test data and seemed to work so I think that I may have altered it somehow in my first try. I will have a look at using it with the correct data and will report back, thanks WBD!

 

[jufglanville]

Hi WBD,

I found that it was working but was placing a gap of around 1000 rows in front of the pasting, not quite sure why but am thinking if I trim the worksheet first, hopefully it will solve that.

One other thing, in your code it copies the data from sheet 2 and places it in sheet 1, whereas I want the data to be copied from sheet 1 and placed in sheet 2, would this be easy to implement?

Thanks again for all your help

 

[wideboydixon]

OK. The gap is down to the way it finds the last row. Presumably there's something in a cell that means that finding the last value in the column finds the wrong row.

Here's my test sheets:

Book1
	A	R	U	AI
2	Apr-17	8500	Campbell Construction Group	-1376.24
3	Apr-17	2300	Archive Holding Account	0
4	Apr-17	1500	Aviva Life	0
5	Apr-17	4593	B J M Invest	-2109
Sheet1

Book1
	A	R	U	AI
2	Oct-17	9000	Campbell Construction Group	-1222
3	Oct-17	2300	Campbell Construction Group	0
4	Oct-17	43665	Calendar Club Ltd	121
5	Oct-17	2323	Camlachie Cooperage	0
Sheet2

I ran this code:

Public Sub NoteMatch()

Dim lastRow1 As Long
Dim lastRow2 As Long
Dim thisRow1 As Variant
Dim thisRow2 As Long
Dim nextRow2 As Long
Dim matchRange As Range
Dim lookupValue As Variant

lastRow1 = Sheets("Sheet1").Range("U" & Sheets("Sheet1").Rows.Count).End(xlUp).Row + 2
lastRow2 = Sheets("Sheet2").Range("U" & Sheets("Sheet2").Rows.Count).End(xlUp).Row
nextRow2 = lastRow2 + 1

For thisRow2 = 2 To lastRow2
    Set matchRange = Sheets("Sheet1").Range("U2:U" & lastRow1)
    lookupValue = Sheets("Sheet2").Cells(thisRow2, "U").Value
    If Application.Match(lookupValue, Sheets("Sheet2").Range("U1:U" & lastRow2), 0) = thisRow2 Then
        Do While True
            thisRow1 = Application.Match(lookupValue, matchRange, 0)
            If IsError(thisRow1) Then
                Exit Do
            Else
                matchRange(thisRow1).EntireRow.Copy Destination:=Sheets("Sheet2").Cells(nextRow2, 1)
                nextRow2 = nextRow2 + 1
                Set matchRange = Sheets("Sheet1").Range("U" & matchRange(thisRow1).Row + 1 & ":U" & lastRow1)
            End If
        Loop
    End If
Next thisRow2

End Sub

And got this output:

Book1
	A	R	U	AI
2	Oct-17	9000	Campbell Construction Group	-1222
3	Oct-17	2300	Campbell Construction Group	0
4	Oct-17	43665	Calendar Club Ltd	121
5	Oct-17	2323	Camlachie Cooperage	0
6	Apr-17	8500	Campbell Construction Group	-1376.24
Sheet2

WBD