Programación

Vamos a analizar distintos códigos de VBA para Office y poder sacarles el máximo rendimineto.

Mover Archivos y crear carpetas

Escrito por Monica Dorado. Publicado en Macros

Excel

Artículo basado en un código realizado por Héctor Miguel Orozco Díaz

En este artículo os vamos a mostrar como podéis crear subcarpetas en un directorio con el mismo nombre que los archivos que existan en un directorio, además de mover dichos archivos a su carpeta correspondiente.
Os ofrecemos dos Procedimientos que podéis ajustar a vuestras necesidades
Códigos realizados en este artículo para una versión superior o igual a MS Office Excel XP

Crear Carpetas

CreateObject("Scripting.FileSystemObject")

Tenemos lo siguiente en un directorio de nuestro Ordenador en este ejemplo →

Unidad → C:\pruebas

Y queremos crear una carpeta por cada archivo que tenemos creado en dicho directorio, pues para ello vamos a hacer lo siguiente →
    • Abrimos un archivo de Excel y le damos a las teclas [ Alt + F11 ] de esta manera abrimos el Editor De Código de VBA de Excel.
    • Nos vamos a menú Insertar → Módulo
    • Ahí en el escenario que nos aparece preparado para escribir código, copiamos y pegamos el siguiente procedimiento →
Sub crear_carpetas()
Dim fs, f, f1, fc, s, ruta As String
ruta = "c:\pruebas\"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ruta)
Set fc = f.Files
For Each f1 In fc
s = Left(f1.Name, 8)
On Error Resume Next
MkDir ruta & s
On Error GoTo mio
Next f1
mio:
MsgBox "terminado"
Set fs = Nothing
Set f = Nothing
End Sub
'modificado de la ayuda de excel
Cuando ejecutemos el código se nos creará una carpeta por cada archivo con mismo nombre que archivo → 8caracteresincluidos espacios sin extensión.

Mover los Archivos

Ahora necesitamos mover nuestros archivos a su carpeta correspondiente →
Para ello necesitamos el siguiente código de Héctor Miguel, que en lugar de recorrer todo el directorio en busca de su misión tal como realiza el procedimiento anterior... Lo que hace el procedimiento siguiente es:
Recoger los nombres de los archivos y carpetas en Dos Matrices en Excel comparando dichas matrices para luego mover dichos archivos a su Sub-carpeta correspondiente.

Podéis observar el código que os muestro a continuación →

Sub Mover_archivos()
    Dim Base As String, sFolder As Object, sFolders(), _
    n As Integer, x As Integer, _
    Cliente As String, Codigo As String, Cambio As String, _
    Nueva As String
    Base = "c:\pruebas\"
    With CreateObject("scripting.filesystemobject").GetFolder(Base)
    ReDim sFolders(.SubFolders.Count)
    For Each sFolder In .SubFolders
    n = n + 1: sFolders(n) = sFolder.Name: Next: End With
    Names.Add "subcarpetas", Join(sFolders, ",")
    Names.Add "subcarpetas", _
    Split(Evaluate(Names("subcarpetas").RefersTo), ",")
    Names.Add "Documentos", _
    "=files(""" & Base & "*.rtf"")": Erase sFolders
    For n = 1 To Evaluate("counta(documentos)")
    On Error Resume Next
    Cliente = Evaluate("index(documentos," & n & ")")
    On Error GoTo mio
    Codigo = Evaluate("left(index(documentos," & n & "),8)")
    x = Evaluate("match(""" & Codigo & """,left(subcarpetas,8),0)")
    If x Then
    Cambio = Base & Evaluate("index(subcarpetas," & x & ")") & "\"
    End If
    Name Base & Cliente As Cambio & Cliente
    n = 0
    Next
mio:
    Names("subcarpetas").Delete: Names("documentos").Delete
    MsgBox "terminado"
    End Sub
 'macro original by Hector Miguel Orozco Díaz acomodada al ariculo
Si lo deseáis también se puede realizar una llamada al Procedimiento →

Sub crear_carpetas()

Desde la macro de Héctor Miguel Orozco de la siguiente manera →

Debajo de las declaraciones poner →

Call crear_carpetas

Sub Mover_archivos()

Dim Base As String, sFolder As Object, sFolders(), _
n As Integer, x As Integer, _
Cliente As String, Codigo As String, _
Cambio As String, Nueva As String

Call crear_carpetas

'resto del codigo

End Sub
De esa manera podéis ejecutar solamente un procedimiento que realice todo de una vez, podeis también quitarle el Mesagebox "Terminado" al procedimiento → Sub crear_carpetas()
Finalmente una vez realizado todo correctamente entonces ya nos quedaría todo ordenado [ Archivos dentro de sus carpetas correspondientes ] visualmente de la siguiente manera →

Arbol msdos

 

Imprimir