Find Match, Copy Row from Sheet1 and Insert Into Sheet2

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.

Kevin A. Naudé Kevin A. Naudé · Accepted Answer · 2011-01-26T16:54:35

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

Find Match, Copy Row from Sheet1 and Insert Into Sheet2

1 Answers