Data Extraction

Sub transfer()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
lastrow1 = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row


Worksheets("Sheet1").Select
Application.ScreenUpdating = False


For i = 2 To lastrow1
myname = Sheets("sheet1").Cells(i, "A").Value


Sheets("sheet2").Activate
lastrow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row


For j = 2 To lastrow2


If Sheets("sheet2").Cells(j, "A").Value = myname Then
Sheets("sheet1").Activate
Sheets("sheet1").Range(Cells(i, "B"), Cells(i, "G")).Copy
Sheets("sheet2").Activate
Sheets("sheet2").Range(Cells(j, "B"), Cells(j, "C")).Select
ActiveSheet.Paste
End If


Next j
Application.CutCopyMode = False
Next i
Sheets("sheet2").Activate
Sheets("sheet2").Range("A1").Select
End Sub