Excel Vba - How to copy and paste matched rows from one sheet to below exact matched rows in another sheet

[fahadun]

I am fairly new in excel vba scenario. What I am trying to accomplish here in this macro is,I have two sheet, two column, sheet1 Column A, sheet2 Column A, both have possible matches in column A. I am trying to find all the matches between two sheets and copy matched entire rows from sheet1 to exactly below matched rows in sheet two with the header of sheet1.

sheet1
Data-----------name
012-----------AAA
022-----------BBB
033-----------CCC

Sheet2
id-----------address
012-----------NYC
021-----------Philly
033-----------CT

Result
id-----------address
012-----------NYC
Data-----------name
012-----------AAA
021-----------Philly
033-----------CT
Data-----------name
033-----------CCC

The code I have so far only copying the first row 3 times, no idea how to fix it.

 Sub oneMacro()

Dim lastrowone As Integer, lastrowtwo As Integer

lastrowone = Sheets("Sheet1").Cells(Rows.Count,1).End(xlUp).Row
lastrowtwo = Sheets("Sheet2").Cells(Rows.Count,1).End(xlUp).Row

For i =1 To lastrowone
For j =1 To lastrowtwo
    If Sheets("Sheet1").Cells(i,1).Value = Sheets("Sheet2").Cells(j,1).Value Then    
Sheets("Sheet1").Cells(i,1).EntireRow.Copy
Sheets("Sheet2").Cells(j,1).Offset(1).Insert Shift:=xlDown 
EndIf
Next j
Next I
End Sub

​

 

[DanteAmor]

Try with this

Sub copy_paste_matched_rows()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim u1 As Double
    
    Application.ScreenUpdating = False
    
    Set sh1 = Sheets("sheet1")
    Set sh2 = Sheets("sheet2")
    
    u1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u1
        Set b = sh2.Columns("A").Find(sh1.Cells(i, "A"), lookat:=xlWhole, LookIn:=xlValues)
        If Not b Is Nothing Then
            sh1.Rows(1).Copy
            sh2.Rows(b.Row + 1).Insert Shift:=xlDown
            sh1.Rows(i).Copy
            sh2.Rows(b.Row + 2).Insert Shift:=xlDown
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

 

[fahadun]

Try with this

Sub copy_paste_matched_rows()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim u1 As Double
    
    Application.ScreenUpdating = False
    
    Set sh1 = Sheets("sheet1")
    Set sh2 = Sheets("sheet2")
    
    u1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u1
        Set b = sh2.Columns("A").Find(sh1.Cells(i, "A"), lookat:=xlWhole, LookIn:=xlValues)
        If Not b Is Nothing Then
            sh1.Rows(1).Copy
            sh2.Rows(b.Row + 1).Insert Shift:=xlDown
            sh1.Rows(i).Copy
            sh2.Rows(b.Row + 2).Insert Shift:=xlDown
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub

Thank you. That Helped a lot.

 

[DanteAmor]

You're welcome & thanks for the feedback.