Find Match, Copy Row from Sheet1 and Insert Into Sheet2 - excel

Question

In Sheet1, I have around 10,000 rows representing different people. Each person has a unique ID located in column D, which is a number sequence stored as text.
In Sheet2, I have around 1,200 person entries that have have a reference to a matching person in Sheet1 located in column A. This reference is the same unique ID used in Sheet1.
What I would like is to have a macro do is this:
read-in the value of cell A1 on Sheet2
find the matching value in column D on Sheet1
copy the matching row in Sheet1
insert the matching row underneath on Sheet2 (row 2)
insert a blank row (row 3)
repeat the steps for the remaining 9,999 entries on Sheet2 so that the matching data always falls underneath the read-in value, followed by a blank row
Any help would be appreciated.

Answer 1

May I advise that in future you show evidence of trying to solve the problem you are having. That way we know you are participating in the community and not attempting to extract free labour from it.
Here is a solution you can try. It starts from the currently selected cell in sheet2.
Function DoOne(RowIndex As Integer) As Boolean
Dim Key
Dim Target
Dim Success
Success = False
If Not IsEmpty(Cells(RowIndex, 1).Value) Then
Key = Cells(RowIndex, 1).Value
Sheets("Sheet1").Select
Set Target = Columns(4).Find(Key, LookIn:=xlValues)
If Not Target Is Nothing Then
Rows(Target.row).Select
Selection.Copy
Sheets("Sheet2").Select
Rows(RowIndex + 1).Select
Selection.Insert Shift:=xlDown
Rows(RowIndex + 2).Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(RowIndex + 3, 1).Select
Success = True
End If
End If
DoOne = Success
End Function
Sub TheMacro()
Dim RowIndex As Integer
Sheets("Sheet2").Select
RowIndex = Cells.row
While DoOne(RowIndex)
RowIndex = RowIndex + 3
Wend
End Sub