满足条件时，将同一行插入下方

Question

我正在处理以下代码，在原始代码下方/下方插入相同的整行。我很难完成这项要求，因为我刚刚开始制作宏。

我已经尝试过搜索但无法正确编码。它正在插入一个空行。但我需要的是插入符合条件的行。下面是我的宏的截图/代码。

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

下面是我刚才使用的代码。谢谢！

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