Macro copiar múltiples archivos a carpeta especifica.
Necesito clasificar varios archivos en una carpeta y copiarlos a carpetas especificas.
Los datos son los siguientes:
Nombres de los archivos a manera de ejemplo son
AF EXP - 565
AF EXP - 566
...
AP EXP - 565
AP EXP - 566
...
RS EXP - 565
RS EXP -566
..
Los archivos debe copiarse a carpetas con los siguientes nombres:
EXP - 565
EXP- 566
...
El criterio de selección es el numero del expediente, es decir que todos los archivos, sin importar las siglas deben ir a la carpeta del expediente.
Ejemplo: Los siguientes expedientes deben ir en la carpeta EXP - 565
AF EXP - 565
AP EXP - 565
RS EXP - 565
Agradezco si me puede colaborar a solucionar esta situación.
1 Respuesta
No indicas dónde vas a ubicar las nuevas carpetas ni si ya están creadas.
El código que adjunto mira en la misma carpeta donde se ubicará el libro con esta macro... si allí ni están las subcarpetas las creará.
Y los archivos se supone se encuentran en el mismo directorio que el libro con esta macro. El código va explicado para que puedas ajustar estos detalles.
Se observa que el nombre ( EXP - 565) va separado con guiones... si no es así ajusta el largo del nombre que ahora quedó en 9.
Entra al Editor de macros, inserta un módulo y allí copia y ajusta este código:
Sub ubicacionArchivos()
'x Elsamatilde
'directorio donde se encuentran los archivos a mover y este libro
Dire = ThisWorkbook.Path
With CreateObject("scripting.filesystemobject")
With .GetFolder(Dire)
'se recorre el conjunto de archivos encontrados en este directorio
For Each Archi In .Files
'si el nombre contiene el texto EXP- se lo moverá .....REVISAR Y AJUSTAR
If InStr(1, Archi, "EXP -") > 0 Then
'se arma nombre de subcarpeta con texto "EXP - nro ... REVISAR Y AJUSTAR
carpe = Mid(Archi.Name, 4, 9)
miDire = ThisWorkbook.Path & "\" & carpe
'si la subcarpeta no existe aún se la crea
If Dir(miDire, vbDirectory) = "" Then
MkDir miDire
End If
'se mueve el archivo a la nueva subcarpeta
Name Archi As miDire & "\" & Archi.Name
End If
Next Archi
End With
End With
End SubPara ejecutarlo hay varias opciones, podés leer sobre el tema en la sección Macros de mi sitio.
