为Excel VBA宏循环设置“Do Until”端点

Question

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

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

当我针对此输入运行此代码时...

我得到了这个输出......

这是您要找的结果吗？如果没有，您能否提供所需结果的更好描述？