How to copy entire row to different sheet

[kimberly090]

Hi,
I have 4 sheet in my excel file,

I wish that when column O value in Overall sheet is equal to Ni, it will copy the row to Ni sheet
When column O value in Overall sheet is equal to NiAu, it will copy the row to NiAu sheet.
When column O value in Overall sheet is equal to NiPd, it will copy the row to NiPd sheet.

I have my code at below, but once I add in new row in my Overall sheet, it will keep duplicate the whole data in the Ni,NiAu,NiPd sheet.
I wish it will only copy the last row when there is new entry inside Overall page.

As below will be my code:

Private Sub Worksheet_Change(ByVal Target As Range)Dim lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, r As Long
lr = Sheets("Overall").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Ni").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("NiAu").Cells(Rows.Count, "A").End(xlUp).Row
lr4 = Sheets("NiPd").Cells(Rows.Count, "A").End(xlUp).Row
    For r = lr To 2 Step -1
        Select Case Range("O" & r).Value
            Case Is = "Ni"
                Rows(r).Copy Destination:=Sheets("Ni").Range("A" & lr2 + 1)
                lr2 = Sheets("Ni").Cells(Rows.Count, "A").End(xlUp).Row
            Case Is = "NiAu"
                Rows(r).Copy Destination:=Sheets("NiAu").Range("A" & lr3 + 1)
                lr3 = Sheets("NiAu").Cells(Rows.Count, "A").End(xlUp).Row
            Case Is = "NiPd"
                Rows(r).Copy Destination:=Sheets("NiPd").Range("A" & lr4 + 1)
                lr4 = Sheets("NiPd").Cells(Rows.Count, "A").End(xlUp).Row
        End Select
    Next r
End Sub

 

[Aaron Blood]

Good question, I always find actions like this interesting...

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ChkCell As Range
    Set ChkCell = Intersect(Target.EntireRow, Range("O:O"))
    Select Case ChkCell.Value
        Case "Ni", "NiAu", "NiPd"
            Dim TargWS As Worksheet
            Set TargWS = Sheets(ChkCell.Value)
            Dim TargRow As Range
            Set TargRow = TargWS.Cells.SpecialCells(xlCellTypeLastCell).End(xlUp).Offset(1, 0).EntireRow
            Target.EntireRow.Copy TargRow
        Case Else
            'do nothing
    End Select
End Sub

...oops sorry, I see a flaw in the specialcells line, I'll correct it momentarily.

 

[Aaron Blood]

This one might be OK for you... test it a bit.
I was concerned about the specialcells method in the code I posted above that was not specific to Column "O" and might cause trouble if some rows on your Overall worksheet might have empty cells when compared to the xlCellTypeLastCell column.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ChkCell As Range
    Set ChkCell = Intersect(Target.EntireRow, Range("O:O"))
    Select Case ChkCell.Value
        Case "Ni", "NiAu", "NiPd"
            Dim TargWS As Worksheet
            Set TargWS = Sheets(ChkCell.Value)
            Dim TargRow As Range
            Set TargRow = Intersect(TargWS.Cells.SpecialCells(xlCellTypeLastCell).EntireRow, TargWS.Range("O:O"))
            Set TargRow = TargRow.End(xlUp).Offset(1, 0).EntireRow
            Target.EntireRow.Copy TargRow
        Case Else
            'do nothing
    End Select
End Sub

 

[igold]

H Kimberly090,

One way around your issue could be that if your Overall page is being continuously added to (meaning you are not deleting rows at anytime), then you could have your code "clearcontents" of your Ni, NiAu, and NiPd pages and then re-write them completely everytime the code runs. The only caveat is that if there is no data on the Ni, NiAu, and NiPd pages, then this will clear the headers. But since you are already doing something with those pages I don't really seeing that as happening.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, r As Long

lr = Sheets("Overall").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Ni").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("NiAu").Cells(Rows.Count, "A").End(xlUp).Row
lr4 = Sheets("NiPd").Cells(Rows.Count, "A").End(xlUp).Row

Sheets("Ni").Rows("2:" & lr2).ClearContents
Sheets("NiAu").Rows("2:" & lr3).ClearContents
Sheets("NiPd").Rows("2:" & lr4).ClearContents

    For r = 2 To lr
        Select Case Range("O" & r).Value
            Case Is = "Ni"
                lr2 = Sheets("Ni").Cells(Rows.Count, "A").End(xlUp).Row
                Rows(r).Copy Destination:=Sheets("Ni").Range("A" & lr2).Offset(1, 0)
            Case Is = "NiAu"
                lr3 = Sheets("NiAu").Cells(Rows.Count, "A").End(xlUp).Row
                Rows(r).Copy Destination:=Sheets("NiAu").Range("A" & lr3).Offset(1, 0)
            Case Is = "NiPd"
                lr4 = Sheets("NiPd").Cells(Rows.Count, "A").End(xlUp).Row
                Rows(r).Copy Destination:=Sheets("NiPd").Range("A" & lr4).Offset(1, 0)
        End Select
    Next r
End Sub

HTH

igold