在下一行的下標超出範圍錯誤

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

我在下一行的開頭處得到下標超出範圍錯誤。在這段代碼中，我試圖使用單元格的突出顯示的顏色來分隔列表。在工作表1中，如果該列有紅色或黃色，則應複製到Sheet2。如果它有綠色，則複製到sheet3。在下一行的下標超出範圍錯誤

來源

2015-05-15 user3493758

試試這個：

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

或者這

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

來源

2015-05-15 07:36:16 R3uK

即使使用這兩個問題的答案後，我得到同樣的錯誤下標越界 – user3493758

在'NextRow ='行？你確定你有「Sheet1」，「Sheet2」和「Sheet3」嗎？因爲線路的其餘部分不應該給你那種錯誤，而長型掩護直到2'147'483'647，所以它也不能掉電。 – R3uK

不，下一行的下一行 – user3493758

在下一行的下標超出範圍錯誤

回答

相關問題