Buscar un archivo y pegar en otra carpeta

Necesito copiar archivos de una ruta y pegarlos en otra específica.-

El problema se origina cuando intento buscar los archivos ya que todos los nombres son distintos

Pero dentro del nombre trae un código real que puedo obtener de una Query ej:

9891004201604260053360008666611.jpg = codigo real es 00086666 (siempre es la misma posición)

Además se deben traer todos los archivos que tengan ese código (aproximadamente 4 archivos) y así también con los otros archivos.-

Utilizo esta macro pero solo copia las que tienen el mismo nombre.

Sub copiar()
'Range("A1").Select
Dim NombreNuevo As String
Dim NombreAnterior As String

On Error Resume Next

For Each Celda In Selection
NombreAnterior = Celda.Value
NombreNuevo = Celda.Offset(0, 3).Value
FileCopy NombreAnterior, NombreNuevo 
End If
Next Celda
On Error GoTo 0
End Sub