fügen Sie die gesamte gleiche Zeile darunter ein, wenn die Bedingung erfüllt wurde

Question

Ich arbeite an dem folgenden Code, um dieselbe ganze Zeile unter/unter Original einzufügen. Es fiel mir schwer, die Anforderung zu erfüllen, denn ich bin neu in der Erstellung von Makros.

Ich habe bereits versucht, aber nicht in der Lage, richtig zu codieren. Es arbeitet daran, eine leere Zeile einzufügen. Aber ich muss die Zeile einfügen, die die Bedingung erfüllt. Unten ist der Screenshot/Code für mein Makro.

Private Sub CommandButton1_Click() 
Dim rFound As Range, c As Range 
Dim myVals 
Dim i As Long 

myVals = Array("LB") '<- starts with 51, VE etc 
Application.ScreenUpdating = False 
With Range("F1", Range("F" & Rows.Count).End(xlUp)) 
    For i = 0 To UBound(myVals) 
     .AutoFilter field:=1, Criteria1:=myVals(i) 
     On Error Resume Next 
     Set rFound = .Offset(2).Resize(.Rows.Count - 1) _ 
      .SpecialCells(xlCellTypeVisible) 
     On Error GoTo 0 
     .AutoFilter 
     If Not rFound Is Nothing Then 
      For Each c In rFound 
       Rows(c.Row + 1).Insert 
       c.Offset(1, -1).Value = ActiveCell.Value 
      Next c 
     End If 
    Next i 
End With 
Application.ScreenUpdating = True 

End Sub 

Answer 1

Sub Test() 

    Dim rng As Range 
    Dim rngData As Range 
    Dim rngArea As Range 
    Dim rngFiltered As Range 
    Dim cell As Range 

    Set rng = Range("A1").CurrentRegion 
    'Exclude header 
    With rng 
     Set rngData = .Offset(1).Resize(.Rows.Count - 1) 
    End With 
    rng.AutoFilter Field:=6, Criteria1:="LB" 
    Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible) 
    rng.AutoFilter Field:=6 
    For Each rngArea In rngFiltered.Areas 
     For Each cell In rngArea 
      '// When inserting a row, 
      '// iteration variable "cell" is adjusted accordingly. 
      Rows(cell.Row + 1).Insert 
      Rows(cell.Row).Copy Rows(cell.Row + 1) 
     Next 
    Next 

End Sub 

Answer 2

Unten finden Sie den Code ich nur verwendet. Vielen Dank!

Private Sub CommandButton2_Click() 

Dim x As Long 

    For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1 

     If Cells(x, "F") = "LB" Then 
     Cells(x, "F") = "ComP" 
     Cells(x + 1, "F").EntireRow.Insert 
     Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow 

     End if 
    Next x 

End Sub