Copiar registros que contenga datos iguales.

Te envío la rutina que colocarás en un módulo. Debes completarla siguiendo las instrucciones. Supongo que después de tanto tiempo ya lo resolverás solo, si te presenta alguna dificultad me avisas.
Option Explicit
Sub BuscarVs()
Dim aBuscar As String
'.....
'definir el resto de las variables
'variables que debes completar:
CeldaBusq = "A2" 'celda donde está el dato a buscar. Podes utilizar un Inputbox
deHojaBusq = "Hoja3" ' Hoja donde está la celda anterior. Si es un InputBox no hace falta
RangoBusq = "A7:D17" 'Rango donde debe efectuarse la búsqueda
deHoja = "Hoja3" ' Hoja donde está el rango de búsqueda
aHoja = "Hoja5" 'Hoja donde debe copiar
'obtener la primer fila libre
filalibre = 2 'asumo que la primer fila donde se copiarán los datos es 2
'Si se hará la copia en una hoja con datos,
'copiar algunas de las rutinas conocidas para obtener la primer
'fila libre en la variable 'filalibre'
aBuscar = Sheets(deHojaBusq).Range(CeldaBusq).Value
Sheets(deHoja).Select
Range("A1").Select
With Worksheets(deHoja).Range(RangoBusq)
Set C = .Find(aBuscar, LookIn:=xlValues)
If Not C Is Nothing Then
PrimCoinc = C.Address
Do
'los offset indican las col de donde se tomarán los datos
C.Copy Destination:=Sheets(aHoja).Cells(filalibre, 1)
C.Offset(0, 1).Copy Destination:=Sheets(aHoja).Cells(filalibre, 2)
C.Offset(0, 2).Copy Destination:=Sheets(aHoja).Cells(filalibre, 3)
filalibre = filalibre + 1
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> PrimCoinc
Range(PrimCoinc).Select
Else
MsgBox "El valor " & aBuscar & " No fue encontrado en el rango indicado", vbInformation, "Valor no encontrado"
End If
End With
End Sub