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
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.
