Copy Only New/Different Items to a List

Status
Not open for further replies.

mharper90

Board Regular
Joined
May 28, 2013
Messages
112
Office Version
  1. 365
Platform
  1. MacOS
I use this macro to take an active roster of people and some data about them, and transfer portions of it to a secondary roster. Unique to the secondary roster is that no one should ever be deleted from the secondary roster. The primary roster is active in the sense that people are constantly being added and deleted.

The macro below copies and pastes all people who meet the criteria of having the word "NO" in column A, which proceeds their Name in column B, and some number data about them in other columns. Currently the macro clears the secondary roster prior to the copy and paste action. I will need to remove this feature, as this will delete someone off of the secondary roster if they no longer exist on the primary roster.

The problem is, in this action of copy and paste, I want the macro to only copy names that don't already exist on the secondary roster (so just the new additions to the primary roster). I don't want a name to populate twice on the secondary roster.

btw, the primary roster is always ws1. ws2 is the secondary roster, but changes based on what quarter of the year it is. The primary roster shows the movement of people, but once someone existed during a quarter, they are never to be deleted from the secondary roster for that quarter. Once the next quarter is activated, all names currently on the primary roster are "new" to the new quarter's secondary roster.

Also, any help in cleaning up my code is much appreciated!

Code:
Sub cpypste5()


    Dim x    As String
    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Main Data")
    Dim ws2 As Worksheet
    Dim r1     As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range, multiAreaRange As Range
    Dim c     As Range
    Dim Lr     As Long


        Set r1 = ws1.Range("B B")
        Set r2 = ws1.Range("C:C")
        Set r3 = ws1.Range("E E")
        Set r4 = ws1.Range("F F")
        Set r5 = ws1.Range("H:H")


    If ws1.Range("$C$4") = "1" Then                 '//Uses Period # from Main Data sheet
        Set ws2 = ThisWorkbook.Sheets("P1 Figure 2—2")         'to direct data to the correct period's
        ElseIf ws1.Range("$C$4") = "2" Then             'Figure 2—2
        Set ws2 = ThisWorkbook.Sheets("P2 Figure 2—2")         '
        ElseIf ws1.Range("$C$4") = "3" Then             'Max of 8 Periods
        Set ws2 = ThisWorkbook.Sheets("P3 Figure 2—2")        '
        ElseIf ws1.Range("$C$4") = "4" Then            '
        Set ws2 = ThisWorkbook.Sheets("P4 Figure 2—2")        '
        Else: Exit Sub                        '
    End If                                //


    Set multiAreaRange = Union(r1, r2, r3, r4, r5)
    
Application.ScreenUpdating = False


    x = "NO"


    ws2.Rows("3:" & Rows.Count).Delete                     'Clears Figure 2-2 selected above


    If Not IsError(Application.Match(x, ws1.Range("A:A"), 0)) Then             '//Copy and paste Name, TLD#, & Dates
                                            'from Main Data page to Figure 2—2
        ws1.Range("E:F").EntireColumn.Hidden = False                'above for all members with
                                            ' "NO" ERC.
        ws1. Range("A3"). CurrentRegion. AutoFilter Field:=1, Criteria1:=x    '
        Intersect(ws1.AutoFilter.Range.Offset(1), multiAreaRange).Copy _
            Destination: =ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)    '
        ws1.AutoFilterMode = False                        '
                                            '
        ws1.Range("E:F").EntireColumn.Hidden = True                '
                                            '
    End If                                        '//


SortGroup2Printout                                'Alphabetizes Figure 2-2


    ws2.Range("A:F").Interior.ColorIndex = xlNone                'Removes any background color copied over


    Lr = ws2.Range("A" & Rows.Count).End(xlUp).Row


    If Lr > 2 Then
        ws2.Range("F3:F" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,8,FALSE)"
        ws2.Range("G3:G" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,9,FALSE)"
        ws2.Range("H3:H" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,10,FALSE)"
        ws2.Range("I3:I" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,11,FALSE)"
        ws2.Range("J3:J" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,12,FALSE)"
        ws2.Range("K3:K" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,13,FALSE)"
        ws2.Range("L3:L" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,14,FALSE)"
        ws2.Range("M3:M" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,15,FALSE)"
        If ws1.Range("$C$4") = "1" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-F3"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,8,FALSE)"
        ElseIf ws1.Range("$C$4") = "2" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:G3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,9,FALSE)"
        ElseIf ws1.Range("$C$4") = "3" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:H3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,10,FALSE)"    
        ElseIf ws1.Range("$C$4") = "4" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:I3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,11,FALSE)"
        ElseIf ws1.Range("$C$4") = "5" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:J3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,12,FALSE)"
        ElseIf ws1.Range("$C$4") = "6" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:K3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,13,FALSE)"
        ElseIf ws1.Range("$C$4") = "7" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:L3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,14,FALSE)"
        ElseIf ws1.Range("$C$4") = "8" Then
            ws2.Range("N3:N" & Lr).Formula = "=E3-SUM(F3:M3)"
            ws2.Range("O3:O" & Lr).Formula = "=VLOOKUP(A3,'Main Data'!B:N,15,FALSE)"
        End If
    Else
    End If


Run ("clearzeros")                            'Removes zeros from column O based on verification




    For Each c In ws2.Range("C3:D" & Lr)                    '//Removes issue/collection dates
        If c > Date Then                        'if they are in the future.
            c = ""                            '
        Else                                '
        End If                                '
    Next                                    '//




    With ws2
        With Application.ErrorCheckingOptions
            .BackgroundChecking = False
            .EvaluateToError = False
            .InconsistentFormula = False
        End With
    End With




    ws2.Range("A1:O" & Lr).Borders.LineStyle = xlContinuous            
    ws2.Range("A1:0" & Lr).BorderAround _
        ColorIndex:=1, Weight:=xlMedium


    With ws2.Range("A" & Rows.Count).End(xlUp).Offset(5, 1)            '//Places CRA Review Box 4 rows
        .Value = "Closeout Review: _______________ Date: _________"    'under last data row.
        With ws2.Range("A” & Rows.Count).End(xlUp).Offset(6, 1)        '
            .Value = "               CRA"                '
        End With                            '
        .Resize(3, 13).Offset(-1, 0).BorderAround _
            ColorIndex:=1, Weight:=xlMedium                '
    End With                                '//


Application.ScreenUpdating = True
End Sub
 

Some videos you may like

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,574
Office Version
  1. 365
Platform
  1. Windows
Duplicate https://www.mrexcel.com/forum/excel-questions/1077363-dealing-duplicates.html#post5175959

Please do not post the same question multiple times. All clarifications, follow-ups, and bumps should be posted back to the original thread.
Per forum rules, posts of a duplicate nature will be locked or deleted (rule 12 here: Forum Rules).

If you do not receive a response, you can "bump" it by replying to it again, though we advise you to wait 24 hours before doing and not to bump a thread more than once a day.

 
Status
Not open for further replies.

Watch MrExcel Video

Forum statistics

Threads
1,127,653
Messages
5,626,101
Members
416,161
Latest member
David1966Lewis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top