For Each Cell ... Next Cell Loop Only Only

Question

我的代碼找到預定義範圍「r」中的值爲「Completed」的單元格，但使用For Each Cell和Next Cell命令不會循環代碼找到多個「完成」單元。

我錯過了什麼？任何幫助，將不勝感激。

Sub Move_Burn() 

Dim Msg As String, Ans As Variant 

    Msg = "Are you sure you want to move the completed pumps?" 

    Ans = MsgBox(Msg, vbYesNo) 

    Select Case Ans 

Case vbYes 

Dim r As Range, cell As Range, mynumber As Long, r2 As Range 

Set r = Range("AR15:AR1000") 
Set r2 = Range("AF15:AF1000") 

mynumber = 1 
For Each cell In r 
    If cell.Value = "Completed" Then 
    Range("AT15:BN15").Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
    Range("AT15:BN15").Interior.ColorIndex = xlNone 

    End If 

    If cell.Value = "Completed" Then 
    cell.Select 
    cell.Value = "Delete" 
    Range(ActiveCell, ActiveCell.Offset(0, -20)).Select 
    Selection.Copy 
    Range("AT15").Select 
    ActiveSheet.Paste 

    Range("BN15").ClearContents 

    End If 

    If cell.Value = "Delete" Then 
    cell.Select 
    Range(ActiveCell, ActiveCell.Offset(0, -20)).Select 
    Selection.Delete Shift:=xlUp 

    End If 

    Next cell 

Case vbNo 
    GoTo Quit: 
    End Select 
Quit: 

    End Sub 

Answer 1

您正在刪除單元格，因此您需要向後循環。

你的循環改成這樣：

For i = 1000 To 15 Step -1 
    '// Your code here 

    '// Instead of referring to cell - use Range("AR" & i) e.g. 

    If Range("AR" & i).Value = "Completed" Then 
     '// rest of code 
    End If 

Next 

Answer 2

在我的Excel中工作，也許嘗試設置相對於你正在工作的工作表的r範圍？所以：

r=sheets("Sheet1").Range("AF15:AF1000") 

Answer 3

與

Selection.Delete Shift:=xlUp 

你跳過隨後行

不喜歡如下：

Option Explicit 

Sub Move_Burn() 

    Dim Msg As String 

    Msg = "Are you sure you want to move the completed pumps?" 
    If MsgBox(Msg, vbYesNo) = vbNo Then Exit Sub 

    Dim iRow As Long, nRows As Long 
    Dim r As Range, cell As Range 

    With Worksheets("Pumps") '<--| change "Pumps" to your actual worksheet name 
     Set r = .Range("AR15", .Cells(.Rows.Count, "AR").End(xlUp)) '<--| set the range to be looped as all column "AR" cells fron row 15 down to last not empty one 
    End With 

    nRows = r.Rows.Count '<--| set the remaining rows counter 
    iRow = 1 '<--| set starting row in the range 
    Do While iRow <= nRows '<--| loop through range rows by means of a row index 

     Set cell = r.Cells(iRow, 1) '<--| set current row index cell 

     If cell.Value = "Completed" Then 
      With Range("AT15:BN15") 
       .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
       .Interior.ColorIndex = xlNone 
      End With 
      cell.Value = "Delete" 
      Range(cell, cell.Offset(0, -20)).Copy 
      Range("AT15").PasteSpecial 
      Range("BN15").ClearContents 
     End If 

     If cell.Value = "Delete" Then 
      Range(cell, cell.Offset(0, -20)).Delete Shift:=xlUp 
      iRow = iRow - 1 '<-- bring row index back one step since you deleted current row 
      nRows = nRows - 1 '<--| update the remaining rows counter 
     End If 

     iRow = iRow + 1 '<-- updated current row index 

    Loop 
End Sub