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]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Temp").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim foundVal As Range
    For Each rng In Sheets("Temp").Range("A2:A" & LastRow)
        With Sheets("Master").Range("A:A")
            Set foundVal = .Find(rng, LookIn:=xlValues, lookat:=xlWhole)
            If foundVal Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End With
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[Legacy 322463]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Temp").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim foundVal As Range
    For Each rng In Sheets("Temp").Range("A2:A" & LastRow)
        With Sheets("Master").Range("A:A")
            Set foundVal = .Find(rng, LookIn:=xlValues, lookat:=xlWhole)
            If foundVal Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End With
    Next rng
    Application.ScreenUpdating = True
End Sub

This worked perfectly, thanks!

 

[Legacy 322463]

Would it be possible to enhance the code to check if the row no longer exists in "Temp" then it is deleted in "Master"?

 

[mumps]

Just to clarify .... you want to look at the unique references in column A of "Master" and then check to see if they exist in column A of "Temp". If they don't exist in "Temp", you want them deleted in "Master". Is this correct?

 

[Legacy 322463]

Just to clarify .... you want to look at the unique references in column A of "Master" and then check to see if they exist in column A of "Temp". If they don't exist in "Temp", you want them deleted in "Master". Is this correct?

Exactly that. It seems counter intuitive but the details of the rows are edited once they are in the master.

 

[Fishboy]

Try:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Temp").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim foundVal As Range
    For Each rng In Sheets("Temp").Range("A2:A" & LastRow)
        With Sheets("Master").Range("A:A")
            Set foundVal = .Find(rng, LookIn:=xlValues, lookat:=xlWhole)
            If foundVal Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        End With
    Next rng
    Application.ScreenUpdating = True
End Sub

Sorry to threadjack, but this is also something I have been trying to get working in my own spreadsheet.

I tried copy / pasting your code and replaced the sheet names with the corresponding names from my workbook. I then edited out all of the 'A' column references and replaced them with 'G' column references (the unique column from my data)

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Imported Sales Data").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rng As Range
    Dim foundVal As Range
    For Each rng In Sheets("Imported Sales Data").Range("G2:G" & LastRow)
        With Sheets("Raw Sales Data").Range("G:G")
            Set foundVal = .Find(rng, LookIn:=xlValues, lookat:=xlWhole)
            If foundVal Is Nothing Then
                rng.EntireRow.Copy Sheets("Raw Sales Data").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
            End If
        End With
    Next rng
    Application.ScreenUpdating = True
End Sub

When I try running the macro it fails here:

rng.EntireRow.Copy Sheets("Raw Sales Data").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)

I had hoped your code would be plug 'n' play, as it were, but I have clearly made an error somewhere. Any idea what I have missed?

 

[mumps]

@ steveb1987: Try this macro on a copy of your file.

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)
            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

@ Fishboy: According to Forum rules, you shouldn't post your question in another person's thread. Please start your own thread with a detailed explanation of what you want to do making reference to specific cells, ranges and worksheets. If you send me a private message with a link to your thread, I'll be pleased to have a look at it.

 

[Fishboy]

@ Fishboy: According to Forum rules, you shouldn't post your question in another person's thread. Please start your own thread with a detailed explanation of what you want to do making reference to specific cells, ranges and worksheets. If you send me a private message with a link to your thread, I'll be pleased to have a look at it.

My bad, sorry all.

 

[Legacy 322463]

I have one further enhancement required, if a Row is found on Temp and on Master, then it should copy the details across again but it needs to be on the same row.

There are a number of additional columns that are manually amended after the copied rows end so it needs to copy in the correct order to not lose the manual columns.

I've expanded the first IF statement, but not sure how to define the paste command for the correct row.

    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 = rng Then
                rng.EntireRow.Copy
                'For the row that matches replace it with a pasted row
            
           ElseIf foundVal1 Is Nothing Then
                rng.EntireRow.Copy Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            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