'Dado un directorio origen y otro destino copia los subdirectorios y archivos de origen a destino
Private Sub CogerArchivos(Directorio As String, Destino As String)
Dim Objeto, Archivos, Nombre, Coleccion
On Error GoTo Errata
Set Objeto = CreateObject("Scripting.FileSystemObject") 'Se establece objeto como Objeto del sistema de archivos
Set Archivos = Objeto.GetFolder(Directorio) 'Se establece Archivo como el directorio origen
Set Coleccion = Archivos.SubFolders 'Se establece Coleccion como los subdirectorios Archivo
'Para cada subdirectorio
For Each Nombre In Coleccion
Objeto.CreateFolder Destino & Nombre.Name & "\" 'Crea la carpeta en el directorio de destino
CogerArchivos Directorio & Nombre.Name & "\", Destino & Nombre.Name & "\" 'Se llama a si misma para copiar los archivos o carpetas dentro del subdiretorio
Next
Set Coleccion = Archivos.Files 'Se establece Coleccion a los archivos de la variable Archivos
'Para cada archivo en el directorio
For Each Nombre In Coleccion
FileCopy Directorio & Nombre.Name, Destino & Nombre.Name 'Copia el archivo de origen a destino
Next
Exit Sub
Errata:
If Err.Number = 70 Then Resume Next 'Permiso denegado
If Err.Number = 58 Then Resume Next 'Por si la carpeta a crear ya existe
If Err.Number = 76 Then 'Por si no se encuentra la ruta a copiar
MsgBox Err.Description, vbCritical, App.Title
Exit Sub
End If
