VBA Deleting every other row

[Gele]

I want this VBA to copy every row where the cell in column A is the colour red to a new sheet and then delete the row. This VBA is successful but does only delete every second row, is there anybody who can help me figure out whats wrong?





Option Explicit
Sub Copy()
Dim i As Long, j As Long, ws1 As Worksheet, ws2 As Worksheet
On Error GoTo Err_Execute
Application.ScreenUpdating = False
Set ws1 = Worksheets("Farg"): Set ws2 = Worksheets("Rod")
ws2.UsedRange.Clear ' clear Sheet 2 previous output
For i = 1 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
If ws1.Range("A" & i).Interior.Color = RGB(255, 0, 0) Then 'copy every red ones and paste it to a new sheet
ws1.Range("A" & i).EntireRow.Copy
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next

For j = 1 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
If ws1.Range("A" & j).Interior.Color = RGB(255, 0, 0) Then 'Deteling every red ones
ws1.Range("A" & j).EntireRow.Delete
End If
Next


ws2.Range("A1") = "Results"
Application.ScreenUpdating = True
MsgBox "The data has been successfully copied."
On Error GoTo 0
Exit Sub
Err_Execute:
MsgBox "An error occurred. Error number " & Err.Number & " - " & Err.Description
End Sub

[pbigos]

In the j For loop add in a j=j-1 inside the if statement (This is were you delete rows)

What is happening is that when you find a row with red and delete it all the rows shift up. Then you advance to the next row. But really the next row is where you were originally at. So you need the j=j-1 to make sure you check the row that just moved.

[stnkynts]

Delete going backwards in loop not forwards. You only need 1 loop

Please Login or Register  to view this content.

[Gele]

Thanks! Now it works!