为 Excel VBA 宏循环设置“直到”端点

Question

我对 VBA 几乎一无所知，需要一些帮助！我记录了一个简单的宏，当在 B 列中找到某个值（“Choice”）时，它将插入一行并执行一些相对剪切/粘贴。我希望这个宏循环直到它到达数据集的末尾（请记住，宏的一部分会插入更多行）。我已经让它循环并做我想做的事，但我不知道如何让它停止而不是无限。搜索空白将无济于事，因为数据集中有多个空白。希望有一个有用的“直到”代码？如果您有解决方案，能否请您在回复中将其附加到我的宏中，以便我看到整个事情的外观？谢谢！！

Sub Macro6()
'
' Macro6 Macro
' Spacer
'
' Keyboard Shortcut: Ctrl+q
'
    Dim c As Range

   For Each c In Range("B1:B3000")
    Cells.Find(What:="choice", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.Offset(1, 0).Range("A1:B1").Select
    Selection.Cut
    ActiveCell.Offset(-1, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Range("A1").Select
    Next
End Sub

Answer 1

Sub Macro6()
'
' Macro6 Macro
' Spacer
'
' Keyboard Shortcut: Ctrl+q
'
Dim c As Range
Dim lastRow As Long

With ActiveSheet

    lastRow = .Cells(.Rows.count, "B").End(xlUp).Row

    For I = lastRow To 1 Step -1

        Debug.Print .Cells(I, 2).Value
        If InStr(1, .Cells(I, 2).Value, "choice") > 0 Then

            .Cells(I, 2).Rows("1:1").EntireRow.Select
            Selection.Insert Shift:=xlDown
            ActiveCell.Offset(1, 0).Range("A1:B1").Select
            Selection.Cut
            ActiveCell.Offset(-1, 0).Range("A1").Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Range("A1").Select

        End If

    Next

End With

End Sub

当我针对这个输入运行这段代码时......

我得到这个输出...

这是您要寻找的结果吗？如果不是，您能否更好地描述您需要的结果？