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