Question

我的代码在预定义范围“r”中找到具有“已完成”值的单元格，但是使用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

与

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")

对于每个单元格...下一个单元格循环仅工作一次

3 个答案: