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

我对VBA几乎一无所知，需要一些帮助！ 我logging了一个简单的macros，它将插入一行，并在列B中find某个值（“select”）时执行一些相对剪切/粘贴操作。我希望此macros循环，直到达到数据集的末尾（记住macros的一部分插入更多的行）。 我已经得到它循环，做我想要的，但我不知道如何使它停止，不是无限的。 search空白不会有帮助，因为数据集中有几个空格。 希望有一个有用的Do Until代码？ 如果你有一个解决scheme，你可以请把它附加到我的macros在你的答复，所以我可以看到整个事情看起来如何？ 谢谢！！

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 

当我运行这个代码对这个input…

我得到这个输出…

这是你寻找的结果吗？ 如果不是，你能提供一个你需要的结果的更好的描述吗？