Excel Macro - Copy unique rows from one worksheet and append to another

[Legacy 322463]

I have a workbook with a worksheet named "Master" which holds a list of projects extracted from another system in CSV format.


I so far have a macro that imports the CSV to a new worksheet "Temp".


I then need to check for new records based on the unique reference in Column A of "Temp" and "Master". If there is a new unique row in "Temp" then it needs to be copied and appended to the end of the current list.


From searching around I have found and amended below, but this only copies the contents from Column A and doesn't append to the list in Master but replaces the rows. (I don't want the existing rows to be impacted):


Sub CopyUnique()
Dim Sh1 As Worksheet
Dim Rng As Range
Dim Sh2 As Worksheet
Set Sh1 = Worksheets("Temp")
Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
Set Sh2 = Worksheets("Master")
Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
End Sub


Any help would be greatly apprectiated!

 

[mumps]

If a row is found on Temp and on Master, you want to copy the row from Temp to Master, replacing the matching row in Master. Is this correct?

 

[Legacy 322463]

That's correct, but it must replace it on the correct row to maintain the manually update columns.

Thanks

 

[mumps]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    LastRow1 = Sheets("Temp").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastRow2 As Long
    LastRow2 = Sheets("Master").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    Dim rng As Range
    Dim foundVal1 As Range
    Dim foundVal2 As Range
    For Each rng In Sheets("Temp").Range("A2:A" & LastRow1)
        With Sheets("Master").Range("A:A")
            Set foundVal1 = .Find(rng, LookIn:=xlValues, lookat:=xlWhole)
            If foundVal1 Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ElseIf Not foundVal1 Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(foundVal1.Row, "A")
            End If
        End With
    Next rng
    For x = LastRow2 To 2 Step -1
        With Sheets("Temp").Range("A:A")
            Set foundVal2 = .Find(Sheets("Master").Cells(x, 1), LookIn:=xlValues, lookat:=xlWhole)
            If foundVal2 Is Nothing Then
                Sheets("Master").Rows(x).EntireRow.Delete
            End If
        End With
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Legacy 322463]

It copies the row and pastes the entire row so overwrites the custom columns with blank cells, is it possible to define the number of columns that it copies instead of the whole row?

Thanks

 

[mumps]

Which columns would you like to copy?

 

[Legacy 322463]

Just up to column R

Thanks

 

[mumps]

Replace this line:

 rng.EntireRow.Copy Sheets("Master").Cells(foundVal1.Row, "A")

with this line:

Sheets("Temp").Range("A" & rng.Row & ":R" & rng.Row).Copy Sheets("Master").Cells(foundVal1.Row, "A")