Como copiar un lista de archivos por extensión y en subcarpetas

Para Dante Amor

Buen día, nuevamente lo saludo para pedirle su ayuda,

Tengo la macro que hace unos días me ayudo solo que ahora necesito adicionarle una opción donde pueda yo elegir si deseo que copie los archivos que se encuentran en las sub carpetas.

Le agradezco de antemano,

Adjunto imagen y códigos

Sub Copiar_Archivos()

rutao = Range("B2")
rutad = Range("B4")
exten = Range("B6")
'
If rutao = "" Or rutad = "" Or exten = "" Then
MsgBox "Completa los datos"
Exit Sub
End If
'
If Right(rutao, 1) <> "\" Then rutao = rutao & "\"
If Right(rutad, 1) <> "\" Then rutad = rutad & "\"
'
u = Range("A" & Rows.Count).End(xlUp).Row
Range("B9:B" & u + 9).ClearContents
'
contador = 0
For I = 9 To u
arch = Cells(I, "A")
If Dir(rutao & arch & exten) <> "" Then
FileCopy rutao & arch & exten, rutad & arch & exten
contador = contador + 1
Cells(I, "B") = "SI"
Else
Cells(I, "B") = "NO"
End If
Next
MsgBox "Archivos copiados: " & contador, vbInformation, "COPIAR ARCHIVOS J.Montalvo"
End Sub