The following assumes data starts in A2 on all sheets (there is a
header row). If this isn't true, you will need to modify the code a
bit.

Hth,
merjet

Sub CopyMatches()
Dim c1 As Range
Dim c2 As Range
Dim c3 As Range
Dim rng1 As Range
Dim rng2 As Range
Dim iRow As Long

With Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
With Worksheets("Sheet3")
.Range("A2:D30").Clear
Set c3 = .Range("A2")
End With
For Each c1 In rng1
For Each c2 In rng2
If c1.Value = c2.Value Then
iRow = iRow + 1
c1.Resize(1, 2).Copy Destination:=c3(iRow)
c2.Offset(0, 1).Resize(1, 2).Copy
Destination:=c3(iRow).Offset(0, 2)
End If
Next c2
Next c1
End Sub