No localiza carpetas en la macro
En primer lugar muy agradecido por la ayuda que puedan prestarme. Tengo creada esta macro en Excel para crear carpetas.
Sub ExtraerCarpetas()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Dim ruta As String
Dim fich As String
Dim ext As String
Dim fichSinExt As String
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
ruta = ActiveWorkbook.Path & "\Imagenes\"
fich = Dir(ruta & Rng(r, c) & ".*")
fichSinExt = Rng(r, c)
ext = extraerExtensionNombre(fich, ".")
If ext <> "" Then 'si tiene extensión es que existe el fichero.
MkDir (ActiveWorkbook.Path & "\" & fichSinExt)
FileCopy ActiveWorkbook.Path & "\Imagenes\" & fich, ActiveWorkbook.Path & "\" & Rng(r, c) & "\" & fich
Name ActiveWorkbook.Path & "\" & Rng(r, 1) As ActiveWorkbook.Path & "\" & Rng(r, 2)
End If
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
Function extraerExtensionNombre(Fichero As String, caracter As String) As String
Dim resultado As String
Dim posicionExt As Integer
posicionExt = InStrRev(Fichero, caracter)
If posicionExt <> 0 Then
resultado = Right(Fichero, Len(Fichero) - posicionExt)
Else
resultado = ""
End If
extraerExtensionNombre = resultado
End Function
Muy buenas.
Este es el diseño de la hoja excel que tiene la macro Columna A y Columna B
IdCódigo iic00
Lo que hace la macro es recorrer la columna A y todo lo que encuentra en una carpeta que se llama Imagenes si el nombre de los ficheros contenidos en él coinciden con el Código iic crea una carpeta con su fichero correspondiente y renombrando la carpeta por el Id
El problema que tengo ahora es el siguiente, os pongo un caso que es la manera más fácil de explicar.
Tengo en la hoja de excel un Id con el valor 9999 (columna A) y el código icc 1234 (columna B) si dentro de la carpeta Imagenes encuentra un fichero llamado 1234.tif crea una carpeta conteniendo el fichero tif y la carpeta la renombra como Id. Hasta ahí perfecto, mi problema es el siguiente. En ocasiones las imagenes tif pueden venir nombradas como 1234_A.tif 1234_B.tif 1234_C.tif y así sucesivamente, como el excel solo vendría con la nomenclatura 1234 no lo encuentra, el tema sería que la busqueda no fuera por el nombre exacto sino por aproximación.
2 respuestas
Luego de la línea con FileCopy...
Colocá estas otras reemplazando la de Name:
Dim carpe As String carpe = ActiveWorkbook.Path & "\" & Rng(r, 1) & "\" Name carpe & fich As carpe & Rng(r, 2) & ext
En ocasiones, como en este caso, es conveniente armar la ruta en una variable ;)
Ya te estoy devolviendo el libro con los arreglos.
Visita:
Cursos de Excel y Macros
--------------------------
Si la carpeta final es el nombre que tienes en la columna B, entonces no tiene caso crear la carpeta con el nombre de la columna A y después renombrarla al nombre de la columna B, lo más simple es crearla desde un inicio con el nombre de la columna B.
Prueba lo siguiente, copia todos los archivos, por ejemplo:
- Si en la columna A tienes "1234"
- Si en la columna B tienes "9999"
- Si en la carpeta imagenes tienes 1234a.tif, 1234b.tif, 1234c.tif
Entonces copia los 3 archivos de imagenes a la nueva carpeta "9999"
Option Explicit Sub ExtraerCarpetas() Dim cell As Range Dim ruta As String, fich As String, nvaRuta As String Dim fichSinExt As String ruta = ActiveWorkbook.Path & "\Imagenes\" For Each cell In Selection nvaRuta = ActiveWorkbook.Path & "\" & cell.Offset(, 1).Value If Len(Dir(nvaRuta, vbDirectory)) = 0 Then MkDir nvaRuta End If fich = Dir(ruta & cell.Value & "*.*") If fich <> "" Then Do While fich <> "" FileCopy ruta & fich, nvaRuta & "\" & fich fich = Dir() Loop End If Next cell End Sub
------------------
Recomendaciones:
Curso de macros. Declarar variables en vba excel. - YouTube
Sal u dos Dante Amo