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

1 Respuesta

2.196.990 pts. En mi sitio encontraran material de ayuda, ejemplos...

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 Sub

Para ejecutarlo hay varias opciones, podés leer sobre el tema en la sección Macros de mi sitio.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas