Help! How do I shift rows down?

Hi,

I have a relatively simple task to ask. First, here is my code:


Sub GetPWCPersonnel()

Dim intRec As Integer, rngData As Range, rngItem As Range, rngAccounts As Range, rngOut As Range
Dim mysht As Worksheet

Application.ScreenUpdating = False

For Each mysht In ThisWorkbook.Worksheets
With mysht
Set rngData = .Range("A71", .Range("A500").End(xlUp)).SpecialCells(xlCellTypeConstants)
End With
With Workbooks("Intermediary - PWC").Worksheets("sheet3")
Set rngAccounts = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With

For Each rngItem In rngData
Set rngOut = rngAccounts.Find(What:=rngItem)

If rngOut Is Nothing Then
rngItem.Offset(0, 2).Value = "N/A"

Else
Set rngOut = rngOut.Offset(0, 1)
Range(rngOut, _
rngOut.End(xlDown).End(xlToRight)).Copy _
Destination:=rngItem.Offset(0, 2)

'need code here!!

End If

Next rngItem
Next mysht
End Sub

How do I code it so that when it copies the information into the destination cell, it will shift all the rows down? Please help! Thanks in advance.

Record a simple macro and it will show you how. Then copy it