Move rows based on cell value to different sheets- not overwriting data

[baba7vb]

Hello,
I would like to update the code below with the following changes

Can anyone help.

Updates Required
-copy and paste non-duplicated rows(with the range in With clause) from sheet 1(row2onwards) if column C=1 and column D="Yes" to sheet 3(target)
-copy and paste non-duplicated rows(with the range from With clause) from sheet 1(row2 onwards) if column C=2 and column D="Maybe" to sheet 4(target)

Sub Tabs()
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "0" Then
         J = J + 1
         With Worksheets("Sheet1")
         Intersect(.Rows(xRg(K).Row), .Range("C5:D577,F5:F577,J5:L577,W5:W577")).Copy Destination:=Worksheets("Sheet2").Range("A" & J)
         'Intersect(.Rows(xRg(K).Row), Range("A:Z")).Delete xlShiftUp
        End With
        
            'xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
          ' Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[sijpie]

What do you mean with non-duplicated? Are you talking about the rows in sheet1?
Do all the cells in a row need to be checked with all the cells in another row to see if the row is unique?
If there are two rows the same, does one row need to be copied, or none of the two?


How many rows are you talking about. The method you use above is going to be pretty slow if you have a few thousand rows.