VBA - How to delete row that meet criteria

[jusho]

Hallo guys, this is my first post. I just learn how easy using vba in my workplace.

I've a problem here. I've a sheet that contain sales report. But sometimes the data isn't filled as their should. I want to remove that 'unclean' data and put it in another workbook.

Example:

Sales Person	Product	A	B	C	D
Jim	Book	1	1	A	A
Dean	Pen	1	1	A
Dean	Pen	1	1
Sarah	Book	1	1	A

<tbody>
</tbody>

The criteria is:
1. If a Book then column a,b,c,d must be filled with either number or text
2. If a Pen then column a,b,c must be filled with either number or text

After i ran the VBA row 4 and 5 are not meet the criteria, so i want to delete the row and put the backup in another workbook ex:error.xls.

Thanks in advance.

 

[jusho]

bump

 

[Gavin T]

You can try something like this:

Sub ArrangeData()

    Dim wsNew   As Worksheet
    Dim wsData  As Worksheet
    Dim LastRow As Integer

    Set wsData = Sheets("Sheet1")
    Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))

    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row

    With wsData
        .Columns("A").Insert
        .Range("A2:A" & LastRow).FormulaR1C1 = _
        "=IF(OR(AND(RC[2]=""Book"",COUNTA(RC[3]:RC[6])<4),AND(RC[2]=""Pen"",COUNTA(RC[3]:RC[5])<3)),1,"""")"
        With .Columns("A").SpecialCells(xlCellTypeFormulas, 1).EntireRow
            .Copy wsNew.Range("A1")
            .Delete
        End With
        .Columns("A").Delete
    End With

    wsNew.Columns("A").Delete
    wsNew.Name = "Error"
    
End Sub

 

[dermie_72]

you could also try this one. Little bit different should provide similar results.

Sub book_pen()
Dim LR As Long, LR2 As Long
Dim cab As Workbook
Dim Nab As Workbook
LR = Cells(Rows.Count, "A").End(xlUp).Row
Set cab = ActiveWorkbook
Set Nab = Workbooks.Add
cab.Activate
For A = 2 To LR
    LR2 = Nab.Sheets("Sheet1").UsedRange.Rows.Count
    If Cells(A, 2).Value = "Book" And Application.WorksheetFunction.CountBlank(Range("C" & A & ":F" & A)) <> 0 Then
        Cells(A, 2).EntireRow.Copy Destination:=Nab.Sheets("Sheet1").Range("A" & LR2)
        Cells(A, 2).EntireRow.Delete
        Else
    End If
    If Cells(A, 2).Value = "Pen" And Application.WorksheetFunction.CountBlank(Range("C" & A & ":E" & A)) <> 0 Then
        Cells(A, 2).EntireRow.Copy Destination:=Nab.Sheets("Sheet1").Range("A" & LR2)
        Cells(A, 2).EntireRow.Delete
        Else
    End If
Next A
End Sub

 

[jusho]

Thanks Gavin T dan dermie 72, both is work but i prefer Gavin T. I ask one more thing, in Gavin T code i have a bit problem. In your code the error rows will copy to new sheet. How if the error rows will copy to existing error.xlsx that i have before. I already try insert open error.xlsx and copy to it. When i debug its running fine, the error.xlsx already open but the paste is null. Thanks Gavin.