Copiar archivos de una carpeta a otra por extensión

Necesito ayuda de los más grandes conocedores de macros.

Tenga una macro que funciona bien pero necesito hacerle unos pequeños cambios para lo que necesito-

1ero. La macro al a darle clic en el botón copiar me pide la extensión y luego la ruta donde se encuentran los nombres de los archivos que están en la fila A1 . ( lo que quisiera es de que en una celda ponga la ruta de origen y otra la ruta de destino y en otra celda poder ingresar la extensión)

2do esta macro al no encontrar un nombre de la lista que esta en la columna A1 se detiene el proceso: ( lo que quiero es de que continué el proceso y que me detecte ya sea poniéndolo de color rojo o con una nota, los archivos que no fueron copiados.)

Solo esas 2 cositas les pido a todo los conocedores, les agradezco de ante mano me puedan ayudar.

Estos son los códigos de la macro:

Sub Copy_files()

Dim Archivo, SubCarpeta, carpeta, archivos, extension, file_origen, file_destino As String
Dim contador As Integer
'Lectura de carpeta y ajustes necesarios
extension = InputBox("Ingrese la extensión, INCLUYENDO EL PUNTO")
carpeta = InputBox("Ingresa la ruta de la carpeta donde buscar:")
If carpeta = "" Then
Exit Sub
ElseIf Right(carpeta, 1) <> "\" Then
carpeta = carpeta & "\"
End If
'Preparación de variables
contador = 1
archivos = Dir(carpeta & "*.*")
'Recorrido del archivo
Do While Len(archivos) > 0
archivos = ActiveSheet.Cells(contador, 1).Value & extension
fn = Dir(archivos & extension)
contador = contador + 1
file_origen = carpeta & archivos
file_destino = ActiveWorkbook.Path & "\" & archivos
On Error GoTo 1
FileCopy file_origen, file_destino
'On Error Resume Next
'On Error GoTo 0

1 On Error GoTo 0
Loop
'1

End Sub

Espero puedan ayudarme, les adjunto una imagen de como necesito que sea la estructura de lo mencionado.