Копирование ячеек под текстом

Question

Я пытаюсь скопировать 3 целых строки ниже ячейки, содержащей текст.

Я уже написал это, но есть некоторые проблемы, которые я не могу решить из-за того, что я новичок в VBA.

Option Explicit

Private Sub SearchandInsertRows()

Dim lRow As Long,  iRow As Long

With Worksheets("Main_Page")
    lRow = .Cells(.Rows.Count, "A").End(xlup).Row
    For iRow = lRow to 1 Step -1
        If .Cells(iRow, "A").Value = Range("D5") Then
            .Rows(iRow).Resize(3).Insert
        End if
    Next iRow
End With

End Sub 

Я хочу, чтобы Excel прочитал весь столбец A и нашел ячейку с тем же текстом, что и ячейка D5 (Text - BillNumber). Затем добавьте 3 пустых строки выше этого. Наконец, скопируйте три ячейки ниже BillNumber и вставьте его в недавно созданные 3 пустых строки.

Вот скриншот, чтобы сделать его более понятным.

Answer 1

Копировать ячейки ниже текста над текстом

Код

Private Sub SearchandInsertRows()

    Dim lRow As Long, iRow As Long

    With Worksheets("Main_Page")
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For iRow = lRow To 1 Step -1
            If .Cells(iRow, "A").Value = .Range("D6") Then
                .Rows(iRow).Resize(3).Insert
                .Rows(iRow + 3 & ":" & iRow + 5).Copy .Rows(iRow)
            End If
        Next iRow
    End With

End Sub

Answer 2

Вот один из способов, удалить строки MsgBox, они для отладки.

Sub insertPaste()
    Dim D5Val As String, wk As Workbook, fVal As Range
    Set wk = ThisWorkbook
    With wk.Sheets("Sheet1")
        'Value from D5
        D5Val = .Range("D5").Value
        'Find D5 on column A
        Set fVal = .Columns("A:A").Find(D5Val, , xlValues, , xlNext)
        If fVal Is Nothing Then
            'Not found
            MsgBox "Not Found"
        Else
            'Found
            MsgBox "Found at: " & fVal.Address
            'Insert 3 Cells on top of the cell found with the data from the 3 cells below
            .Range("A" & (fVal.Row + 1) & ":A" & (fVal.Row + 3)).Copy
            .Range("A" & fVal.Row & ":A" & (fVal.Row + 2)).Insert Shift:=xlDown
            Application.CutCopyMode = False
        End If
    End With
End Sub