对于每个细胞…下一个细胞循环只工作一次

Question

我的代码在预定义的范围"r"中查找值为"Completed"的单元格，但是使用For Each Cell和Next Cell命令不会循环代码以查找多个"Completed"单元格。

我错过了什么?如有任何帮助，不胜感激。

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

with

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

Answer 3

在我的excel中工作，也许尝试设置相对于你正在工作的工作表的r范围?所以:

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