Help with transplanting data - non duplicates one sheet to another?

[HowDoIExcel]

Hello helpful excelites,

I'm trying to create a macro that is able to pull through data that is not a duplicate(marked as red), into the current existing database, that will add it on the bottom where there are free rows. The 6th column is static and will have a unique identifier, and for testing purposes its in column 3 for the other worksheet. This will have to sort through about 22,000 rows so I'm looking for ways to speed up this code and make it more efficient.

Each row in the UniqueID column(3&6) will be filled always, other rows may not always be filled so I'm looking to use a static range (unless there is a better way that also always ensures that the entire relevant data set on that row is captured).



Sub Entry_Additions()
'Variables
Dim entry_row As Long, new_entry_row As Long, column_shifter As Long, testing_row As Long
empty_row = 1 'This will find the empty row for new entries to be placed into
entry_row = 2 'Will hold the row value of the will be entered data, this is used to pull from all the other columns
Application.ScreenUpdating = False
Sheets("NewEntries").Select

Do While Sheets("NewEntries").Cells(entry_row, 6).Value <> ""
Sheets("NewEntries").Cells(entry_row, 6).Select

If ActiveCell.Interior.color = RGB(255, 0, 0) Then
Sheets("NewEntries").Cells(entry_row, 6).Interior.color = RGB(255, 0, 0)

Else
Sheets("NewEntries").Range(Cells(entry_row, 1), Cells(entry_row, 10)).Copy 'This is just a random interval, more than enough to hold all the data in each row
empty_row = Sheets("Farmer Database").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
Sheets("Farmer Database").Cells(empty_row, 1).PasteSpecial
End If
entry_row = entry_row + 1
Loop
End Sub

If anyone has any idea how to make this more concise, that would be appreciated.

 

[Takae]

please try both code.

Sub Entry_Additions()
'Variables
Dim entry_row As Long, new_entry_row As Long, column_shifter As Long, testing_row As Long, empty_row As Long
empty_row = 1 'This will find the empty row for new entries to be placed into
entry_row = 2 'Will hold the row value of the will be entered data, this is used to pull from all the other columns
Application.ScreenUpdating = False
empty_row = Sheets("Farmer Database").Cells(Rows.count, 3).End(xlUp).Offset(1, 0).Row
    With Sheets("NewEntries")
        Do While .Cells(entry_row, 6).Value <> ""
            If .Cells(entry_row, 6).Interior.Color = RGB(255, 0, 0) Then
                'This is just a random interval, more than enough to hold all the data in each row
                .Range(.Cells(entry_row, 1), .Cells(entry_row, 10)).Copy Sheets("Farmer Database").Cells(empty_row, 1)
                empty_row = empty_row + 1
            End If
            entry_row = entry_row + 1
        Loop
    End With
End Sub

AutoFilter(If you are using 2007 or newer)

Sub sample_Entry_Additions()
Dim empty_row As Long
empty_row = Sheets("Farmer Database").Cells(Rows.count, 3).End(xlUp).Row + 1
    With Sheets("NewEntries")
        .Range("A1").AutoFilter Field:=6, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
        .Range(.Range("A2"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 9).Copy Sheets("Farmer Database").Cells(empty_row, 1)
    End With
End Sub

 

[HowDoIExcel]

Hello Takae,

While the second code doesn't work, the first one does for one caveat, any file transferred is painted red!

 

[Takae]

Sorry, it was an opposite code.
About second code, what does it mean "doesn't work"?
Does it say any error?

Sub Entry_Additions_1()'Variables
Dim entry_row As Long, new_entry_row As Long, column_shifter As Long, testing_row As Long, empty_row As Long
empty_row = 1 'This will find the empty row for new entries to be placed into
entry_row = 2 'Will hold the row value of the will be entered data, this is used to pull from all the other columns
Application.ScreenUpdating = False
empty_row = Sheets("Farmer Database").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
    With Sheets("NewEntries")
        Do While .Cells(entry_row, 6).Value <> ""
            If .Cells(entry_row, 6).Interior.Color <> RGB(255, 0, 0) Then
                'This is just a random interval, more than enough to hold all the data in each row
                .Range(.Cells(entry_row, 1), .Cells(entry_row, 10)).Copy Sheets("Farmer Database").Cells(empty_row, 1)
                empty_row = empty_row + 1
            End If
            entry_row = entry_row + 1
        Loop
    End With
End Sub

Auto Filter

Sub sample_Entry_Additions_2()Dim empty_row As Long
empty_row = Sheets("Farmer Database").Cells(Rows.Count, 3).End(xlUp).Row + 1
    With Sheets("NewEntries")
        .Range("A1").AutoFilter Field:=6, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterNoFill
        .Range(.Range("A2"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 10).Copy Sheets("Farmer Database").Cells(empty_row, 1)
        .Range("A1").AutoFilter
    End With
End Sub

 

[HowDoIExcel]

Hi,

The second code marks absolutely everything as red, as opposed to the first code which would mark everything in column 6 as red! I'll give your new code a try soon and let you know.

Thank you for all your help!