VBA to copy rows if condition is met but not duplicates

[KMLEGG]

I am an absolute novice at VBA but I need to figure it out at least a bit for a work project.

We have a spreadsheet that we use to log our trailer sales. We created another spreadsheet to keep track of the license plates and the cancellations.

The first macro needs to pull only the rows that have ME plates to the "Maine Plates" tab. Once on that tab, we will add a "Y" into column G to indicate that the registration was pulled.

The second macro will pull the rows that have a "Y" in column G.

My Macros work but I end up with duplicate information. Is there a way to only have new entries copied?

Module 1
Sub Update()

a = Worksheets("Sold Units").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To a

If Worksheets("Sold Units").Cells(i, 5).Value = "ME" Then

Worksheets("Sold Units").Rows(i).Copy
Worksheets("Maine Plates").Activate
b = Worksheets("Maine Plates").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Maine Plates").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sold Units").Activate

End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("Sold Units").Cells(1, 1).Select
End Sub

Module 2
Sub Cancellations()

a = Worksheets("Maine Plates").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To a

If Worksheets("Maine Plates").Cells(i, 7).Value = "Y" Then

Worksheets("Maine Plates").Rows(i).Copy
Worksheets("Reg Cancelled").Activate
b = Worksheets("Reg Cancelled").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Reg Cancelled").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Maine Plates").Activate

End If
Next

Application.CutCopyMode = False


End Sub

 

[mumps]

It looks like your data starts in row 5. Do you have headers in row 4 of the "Sold Units" sheet? It would be easier to help if you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[KMLEGG]

Dropbox - File Deleted - Simplify your life

www.dropbox.com

Dropbox - File Deleted - Simplify your life

www.dropbox.com

Sales is where the raw data would be pulled from.

 

[GWteB]

Hello KMLEGG, welcome to the board.
This might work ...

Public Sub Update()

    Dim rngSrce     As Worksheet
    Dim rngDest     As Worksheet
    Dim lLastRow    As Long
    Dim i           As Long

    Set rngSrce = ThisWorkbook.Worksheets("Sold Units")
    Set rngDest = ThisWorkbook.Worksheets("Maine Plates")

    With rngSrce
        lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lLastRow
            If .Cells(i, 5).Value = "ME" Then
                .Rows(i).Copy Destination:=rngDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                .Rows(i).Delete Shift:=xlUp
            End If
        Next
        .Activate
        .Cells(1, 1).Select
    End With

    Set rngSrce = Nothing
    Set rngDest = Nothing

End Sub


Public Sub Cancellations()

    Dim rngSrce     As Worksheet
    Dim rngDest     As Worksheet
    Dim lLastRow    As Long
    Dim i           As Long

    Set rngSrce = ThisWorkbook.Worksheets("Maine Plates")
    Set rngDest = ThisWorkbook.Worksheets("Reg Cancelled")

    With rngSrce
        lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lLastRow
            If .Cells(i, 7).Value = "Y" Then
                .Rows(i).Copy Destination:=rngDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                .Rows(i).Delete Shift:=xlUp
            End If
        Next
        .Activate

    End With

    Set rngSrce = Nothing
    Set rngDest = Nothing

End Sub

 

[mumps]

Click here to download your file. In the "Sold Units" sheet, click the button. Once the data has been copied to the "Maine Plates" sheet, click on any cell in column G and select the "Y". That row will automatically be copied to the "Reg Cancelled" sheet. Can you explain when and how you get duplicate information? What happens if you want the rows with "TN" instead of "ME"?

 

[KMLEGG]

Click here to download your file. In the "Sold Units" sheet, click the button. Once the data has been copied to the "Maine Plates" sheet, click on any cell in column G and select the "Y". That row will automatically be copied to the "Reg Cancelled" sheet. Can you explain when and how you get duplicate information? What happens if you want the rows with "TN" instead of "ME"?

The Sales Log will be updated throughout the year so when I hit update, all entries that were already on the Maine Plates sheet are duplicated. When we update, I only want to pull the new entries.

 

[mumps]

Try:

Sub Update()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim srcWS As Worksheet, desWS As Worksheet, lastRow As Long, VIN As Range, fnd As Range
    Set srcWS = Sheets("Sold Units")
    Set desWS = Sheets("Maine Plates")
    lastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS.Cells(1).CurrentRegion
        .AutoFilter 6, "ME"
        For Each VIN In srcWS.Range("E2:E" & lastRow).SpecialCells(xlCellTypeVisible)
            Set fnd = desWS.Range("F:F").Find(VIN, LookIn:=xlValues, lookat:=xlWhole)
            If fnd Is Nothing Then
                With desWS
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Range("B" & VIN.Row).Value
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Range("A" & VIN.Row).Value
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(, 2).Value = Range("C" & VIN.Row).Resize(, 2).Value
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = Range("F" & VIN.Row).Value
                    .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Value = Range("E" & VIN.Row).Value
                End With
            End If
        Next VIN
    End With
    lastRow = desWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With desWS.Range("G2:G" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Y"
    End With
    srcWS.Range("A1").AutoFilter
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[KMLEGG]

@mumps
I added new information to the sales log and updated the "sold Units" tab. The new entries show up on this tab but when I hit update, even with the adjustments from above, the new entries do not show.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[mumps]

Try:

Sub Update()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim srcWS As Worksheet, desWS As Worksheet, lastRow As Long, Plate As Range, fnd As Range
    Set srcWS = Sheets("Sold Units")
    Set desWS = Sheets("Maine Plates")
    lastRow = srcWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With srcWS.Cells(1).CurrentRegion
        .AutoFilter 6, "ME"
        For Each Plate In srcWS.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible)
            Set fnd = desWS.Range("D:D").Find(Plate, LookIn:=xlValues, lookat:=xlWhole)
            If fnd Is Nothing Then
                With desWS
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Range("B" & Plate.Row).Value
                    .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Range("A" & Plate.Row).Value
                    .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(, 2).Value = Range("C" & Plate.Row).Resize(, 2).Value
                    .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = Range("F" & Plate.Row).Value
                    .Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Value = Range("E" & Plate.Row).Value
                End With
            End If
        Next Plate
    End With
    lastRow = desWS.Range("A" & srcWS.Rows.Count).End(xlUp).Row
    With desWS.Range("G2:G" & lastRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Y"
    End With
    srcWS.Range("A1").AutoFilter
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[KMLEGG]

@mumps
Seems to be working out. I'll keep you updated.

Thanks so much!