Macro para copiar pegar archivos misma extensión

Quizá debería haberte pedido todos los detalles, pero aquí tienes una macro que puede servirte directamente o ser una buena base para lo que quieres hacer.

Sub MoverFicheros()
Dim Ruta, Destino As String
Dim fs, Carpeta, Archivo, SubCarpeta As Object
Ruta = "C:\peanut\registro\"
Destino = "C:\temp\"
Set fs = CreateObject("scripting.FileSystemObject")
Set Carpeta = fs.getfolder(Ruta)
For Each Archivo In Carpeta.Files
  If LCase(Right(Archivo, 4)) = ".doc" Then
    fs.movefile Archivo, Destino
  End If
Next
For Each SubCarpeta In Carpeta.subfolders
  For Each Archivo In SubCarpeta.Files
    If LCase(Right(Archivo, 4)) = ".doc" Then
      fs.movefile Archivo, Destino
    End If
  Next
Next
End Sub

La Ruta y el Destino por supuesto las tienes que poner tú o conseguirlas con un dialogo de abrír ficheros.

El primer For Each a lo mejor no lo necesitas, sirva para los ficheros que estén en la carpeta Ruta sin estar en ninguna subcarpeta. El segundo es el que mueve los ficheros de las subcarpetas.

Te recomendaría para probar que en vez de la orden MoveFile uses CopyFile ya que así puedes repetir hasta que quede a tu gusto y al final ya pones MoveFile.

Como te decía esto puede ser un principio y a lo mejor necesitas más, si es así pidemelo. Lo mismo que si necesitas explicaciones sobre el código. Y si ya está bien no olvides puntuar.