Subscript out of range error at Next Row

Question

Sub ChangeColor()

Dim rCell As Range
Dim FinalRow As Long, x As Long
Dim NextRow As Long

With Sheet1
    For Each rCell In .Range("H2", .Cells(.Rows.Count, 8).End(xlUp)).Cells
        If rCell.Value > Date + 1 Then
            rCell.Interior.Color = vbRed
        ElseIf rCell.Value < Date - 15 Then
            rCell.Interior.Color = vbYellow
        Else
            rCell.Interior.Color = vbGreen
        End If
    Next rCell


 FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
    ' Decide if to copy based on column D

    If ((Cells(x, 8).Interior.Color = vbRed) Or (Cells(x, 8).Interior.Color = vbYellow)) Then

        Cells(x, 1).Resize(1, 33).Copy
        Sheets("Sheet2").Select
        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(NextRow, 1).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
     ElseIf ((Cells(x, 8).Interior.Color = vbGreen)) Then
        Cells(x, 1).Resize(1, 33).Copy
        Sheets("Sheet3").Select
        NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(NextRow, 1).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
    End If
Next x


End With

End Sub

I am getting Subscript out of range error at the Beginning of next row. In this code, i am trying to separate the list using highlighted color of the cell. In sheet1, if the column has either Red or yellow, it should copy to Sheet2. If it has Green then copy to sheet3.

R3uK R3uK · Accepted Answer · 2015-05-15T07:36:16

Try this :

Sub ChangeColor()

Dim rCell As Range, _
    FinalRow As Long, _
    x As Long, _
    NextRow As Long

With Sheets("Sheet1")
    For Each rCell In .Range("H2", .Cells(Rows.Count, "H").End(xlUp)).Cells
        If rCell.Value > Date + 1 Then
            rCell.Interior.Color = vbRed
        ElseIf rCell.Value < Date - 15 Then
            rCell.Interior.Color = vbYellow
        Else
            rCell.Interior.Color = vbGreen
        End If
    Next rCell

    FinalRow = .Cells(Rows.Count, 1).End(xlUp).Row

    'Loop through each row
    For x = 2 To FinalRow
        ' Decide if to copy based on column D
        If ((.Cells(x, 8).Interior.Color = vbRed) Or (.Cells(x, 8).Interior.Color = vbYellow)) Then
            NextRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(x, 1).Resize(1, 33).Copy Destination:=Sheets("Sheet2").Cells(NextRow, 1).Paste

         ElseIf (.Cells(x, 8).Interior.Color = vbGreen) Then
            NextRow = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(x, 1).Resize(1, 33).Copy Destination:=Sheets("Sheet3").Cells(NextRow, 1).Paste

        End If
    Next x
End With

End Sub

Or this

For x = 2 To FinalRow
    ' Decide if to copy based on column D

    If ((Cells(x, 8).Interior.Color = vbRed) Or (Cells(x, 8).Interior.Color = vbYellow)) Then
        Cells(x, 1).Resize(1, 33).Copy
        NextRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1
        ActiveSheet.Cells(NextRow, 1).Paste

     ElseIf ((Cells(x, 8).Interior.Color = vbGreen)) Then
        Cells(x, 1).Resize(1, 33).Copy
        NextRow = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1
        ActiveSheet.Cells(NextRow, 1).Paste

    End If
Next x

Sheets("Sheet1").Select

Subscript out of range error at Next Row

1 Answers