Crear carpeta según valores de una tabla de excel

Tengo un problema que seguramente será fácil de solucionar pero que soy incapaz de dar con ello. Intentaré explicarme lo mejor posible.

Tengo una carpeta que se llama Archivo en la cual contiene lo siguiente:

Un fichero excel con macro denominado provincia.xlsm

Una carpeta llamada Imagenes que contiene ficheros de imagen

El fichero excel tiene este formato

ID Código iic
1111 A111222
2222 B222333
3333 C444555
4444 D555666
Lo que necesito es que a través de un código generar carpetas con los valores que selecciono. Para ello he incluido este código

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Este código lo que hace es generar carpetas dentro de la carpeta archivo con el nombre de los valores seleccionados. Hasta ahí bien pero y aquí mi duda ¿Cómo puedo hacer para que dentro de cada una de esas carpetas le incluya su fichero de imagen correspondiente? Por ejemplo el ID 1111 tiene dentro de Imagenes un fichero llamado 1111.jpg pues que lo meta dentro de esa carpeta.

Espero haberme explicado bien. Como siempre muy agradecido por la ayuda que me puedan prestar.

1 respuesta

Respuesta
1

Para copiar el archivo a esa carpeta, puede usar "FileCopy origen, destino"

Si quiere moverlo, puede hacerlo de dos maneras:

- Lo mueve, directamente con "Name origen As destino"

O bien

- Primero lo copia con "FileCopy origen, destino" y después borra el archivo origen con "Kill origen"

Uff, perdona pero mis conocimientos de códigos de visual son muy limitados. ¿Me lo podrías indicar de forma más explícita? Muchas gracias

Si quiere copiar el archivo de la carpeta Imagenes a la carpeta que acaba de crear tiene que hacer:

FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"

Si lo que quiere es mover el archivo:

Name ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg" As ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"

Gracias. Lo he puesto así y no me funciona 

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c) & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"
End Sub

Lógico. Tendrá que ponerlo dentro del bucle.

Póngalo después de la instrucción en la que se crea la carpeta.

Es decir, después del MkDir.

¡Funciona, muchas Gracias! 

Una pregunta más si no le importa. Tal como está puesto el código se crean todas las carpetas, es decir si selecciono la columna entera me sale todas las carpetas independientemente que tengan contenido o no, ¿habría forma de que solo generase las carpetas con contenido?

Sí, claro.

Habría que verificar que existe el archivo origen antes de crear la carpeta y tratar de copiar el archivo. Algo así como:

If Len(Dir(ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg")) > 0 Then
    MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
    FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"
End If

donde antes sólo tenía:

MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"

No sé donde poner esta ultima instrucción dentro del código

If Len(Dir(ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg")) > 0 Then
    MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
    FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"
End If

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows

If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c) & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Como le decía, tiene usted que reemplazar esto:

MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"

por esto:

If Len(Dir(ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg")) > 0 Then
    MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
    FileCopy ActiveWorkbook.Path & "\Imagenes\" & Rng(r, c)  & ".jpg", ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & Rng(r, c) & ".jpg"
End If

Ese "If ..." que se añade al código inicial verifica la existencia del archivo de imagen que se va a copiar. Si no existe, no se ejecuta la parte de creación de la carpeta y la copia del archivo.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas