Set 'Do Until' Endpunkt für Excel VBA Makro Loop

Question

Ich weiß fast nichts über VBA und brauche Hilfe! Ich habe ein einfaches Makro aufgenommen, das eine Zeile einfügen und relatives Ausschneiden/Einfügen ausführen wird, wenn ein bestimmter Wert ("Choice") in Spalte B gefunden wird. Ich möchte, dass dieses Makro eine Schleife ausführt, bis es das Ende des Datensatzes erreicht (Denken Sie daran, dass ein Teil des Makros mehr Zeilen einfügt, wenn es geht). Ich habe es in die Schleife gebracht und mache, was ich will, aber ich kann nicht herausfinden, wie ich es stoppen und nicht unendlich sein kann. Die Suche nach Leerzeichen hilft nicht, da innerhalb des Datensatzes mehrere Leerzeichen stehen. Auf einen hilfreichen Do Until-Code hoffen? Wenn Sie eine Lösung haben, können Sie sie bitte an mein Makro in Ihrer Antwort anhängen, damit ich sehen kann, wie das Ganze aussehen würde? Danke!!

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 

Wenn ich diesen Code gegen diesen Eingang laufen ...

ich diese Ausgabe erhalten ...

Ist dies das Ergebnis Du hast gesucht? Wenn nicht, können Sie das gewünschte Ergebnis besser beschreiben?