复制文本下方的单元格

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具有相同文本的单元格（文本为BillNumber）。然后在其上方添加3个空白行。最后，复制BillNumber下面的三个单元格，并将其粘贴到最近创建的3个空白行中。

下面是截图，以使其更易于理解。

Answer 1

这是一种方法，删除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

Answer 2

在文本上方的文本下方复制单元格

代码

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