Matching cells

[saman110 via OfficeKB.com]

Hello all.

The macro below compares col. A of compare and master sheet with each other
and then copy and pastes the corresponding cells.
The problem is it copies and pastes the first match that it finds. Is there
any way to copy and paste all the matches below each other? here is what I
mean.

Master sheet.

A B C D
sam 1 10 100
sam 2 20 200
sam 3 30 300
sam 4 40 400
Tom 5 6 7

Compare sheet.

A B C D
Sam
Sam
Tom

Compare sheet after running the program.

A B C D
Sam 1 10 100
Sam 2 20 200
3 30 300
4 40 400
Tom 5 6 7

Here is my VBA Without pasting all matches.

Option Explicit
Sub CopyIDData()
Dim rng As Range
Dim rng1 As Range
Dim cell As Range
Dim res As Variant

With Worksheets("Compare")
Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With

With Worksheets("Master")
Set rng1 = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each cell In rng.Cells
If cell.Value = "" Then
'skip it
Else
res = Application.Match(cell, rng1, 0)
If Not IsError(res) Then
rng1(res, 2).Resize(1, 3).Copy Destination:=cell.Offset(0, 1)
End If
End If
Next cell
End Sub

'Thank you.