OPTIMIZAR BUSQUEDA DE ARCHIVOS CON MACRO (Cambio de For each)
publicado
Hola a todos muy buenos dias como estan!
A los grandes maestros de este grupo, queria consultar por una macro que estoy usando para buscar archivos en una carpeta, actualmente la macro me funciona, recorre todos los archivos dentro de una carpeta pero no que no logre es que si hay subcarpetas entre tambien a las sub carpetas, asi que tengo que hacerlo uno por uno
aun asi seleccionando carpeta por carpeta, es muy muy muy lento?.... demora 11 minutos en ejecutarse para evaluar por ejemplo una carpeta con 600 archivos...
me gustaria saber si existe o no una forma de optimizar para que demore menos... porque lo que necesito es evaluar MUUUUCHAS CARPETAS con esa cantidad de contenio o mas.... y voy a demorar la vida...
pero bueno, no se si es posible o no... quizas estaba pensando que si aplico un filtro para que solo me traiga los arhivos de imagen o video, (aunque la carpeta que me duro esa cantidad de tiempo tenia solo imagenes), no se si es el uso del for each lo que hace que sea tan lenta... o si son las formulas que le puse que use con la grabadora de macros: que son de dividir columnas, y de buscar en otra hoja otros datos...
podrian ayudarme a optimizarla por favor? o decirme si es imposible ? ?por favor o si tengo que llegar a la jubilacion ? para evaluarlas a todas jajaja
Tambien pregunto, por las dudas , si es posible mejorar la busqueda, para que no tenga que entrar carpeta por carpeta y pueda incluir la busqueda dentro de subcarpetas?
les comparto el codigo y el archivo, el codigo lo estoy ejecutando en el userform al presionar el boton buscar carpeta...
millones de gracias de antemano a todas las personas que son parte de comunidad que tengas todos un lindo dia!
Private Sub FVBuscarFotosEtiquetas_Click()
tiempo = Now
'Declaramos variables
Dim FSO As Object, directorio As String
Dim dir_Archivo As Variant
Dim WS As Worksheet
Dim i As Long
Dim FolderPath As String
Dim objShell, objFolder, objFolderItem As Object
Dim oFolder, oFile As Object
'Abrimos ventana de diálogo para seleccionar carpeta
Set dir_Archivo = application.FileDialog(msoFileDialogFolderPicker)
dir_Archivo.Show
'Si no seleccionamos nada salimos del proceso
If dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If
'Capturamos el directorio del archivo seleccionado
directorio = dir_Archivo.SelectedItems(1)
'Creamos objeto y ejecutamos función Carpeta
Set FSO = CreateObject("Scripting.FileSystemObject")
'GetFileAttributes FSO.GetFolder(Directorio)
application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application") 'D:\PAULA\yaguarete\Jaguar tracker\album tigres
FolderPath = directorio '"E:\Yaboti 2021\Aguante Brpy36 14-08-21 E" '"G:\Till\0262529629\" 'Set folderpath
Set WS = ActiveWorkbook.Worksheets("FotosEtiquetadas") 'Set sheet name
'WS.Range("A1:O1").Value = Array("URLArchivo", "NombredeArchivo", "Estacion", "Fecha Captura", "Hora", "NombreImagen", "Fecha Importacion", "TipoArchivo", "Tamaño", "PercepcionTipoArchivo", "Etiquetas o Tags", "Sitio", "Estacion", "Especie", "Observaciones")
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.getfolder(FolderPath)
i = application.CountA(WS.Range("A:A")) + 1 'First row to print result
Dim nombrev As String
Dim repeticiones As Integer
nombrev = oFolder
repeticiones = WorksheetFunction.CountIfs(Range("Ae:Ae"), nombrev)
If repeticiones > 0 Then
MsgBox "La Carpeta ' " & oFolder & " ' ya se encuentra cargada en el sistema.", vbExclamation
Else
For Each oFile In oFolder.Files
On Error Resume Next 'If any attribute is not retrievable ignore and continue
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(oFile.Name)
' etiquetas del archivo o file -----------------------------------------------------------------------
WS.Cells(i, 1).Value = objFolder.GetDetailsOf(objFolderItem, 0) 'nombre del archiv
WS.Cells(i, 2).Value = "=IFERROR(VLOOKUP(CONCAT(RC[3],""-"",RC[1]),'RefEstaciones-Sitios'!C[1]:C[4],4,FALSE),"""")"
' Obtención elementos del ID -------------------------------------------------------------------------
WS.Cells(i, 3).Value = "=@ExtraeDato(""A"",RC[+27])" 'sitio
'WS.Cells(i, 4).Value = "" 'Muestreo Sistemtico
WS.Cells(i, 5).Value = "=SepararEnColumnas(RC[-4], 1, "" "")" 'Estacion
WS.Cells(i, 6).Value = "=IFERROR(VLOOKUP(CONCAT(RC[-1],""-"",RC[-3]),'RefEstaciones-Sitios'!C[-3]:C[-1],2,FALSE),"""")" 'Latitud
WS.Cells(i, 7).Value = "=IFERROR(VLOOKUP(CONCAT(RC[-2],""-"",RC[-4]),'RefEstaciones-Sitios'!C[-4]:C[-2],3,FALSE),"""")" 'Longitud
WS.Cells(i, 8).Value = "=IFERROR(SepararEnColumnas(RC[-7], 2, "" ""),"""")" 'FechaCaptura
WS.Cells(i, 9).Value = "=IFERROR(SepararEnColumnas(RC[-8], 3, "" ""),"" "")" 'Hora
WS.Cells(i, 10).Value = "=@ExtraeDato(""C"",RC[+20])" 'Especie
'WS.Cells(i, 11).Value = "" 'Independizator
' ------------------------------------------------------------------------------------------------------
'keywords o Tags importados Bridge --------------------------------------------------------------------
WS.Cells(i, 12).Value = "" ' tipo de Registro
WS.Cells(i, 13).Value = "=@ExtraeDato(""D"",RC[+17])" 'Observaciones
WS.Cells(i, 14).Value = "=@ExtraeDato(""F"",RC[+16])" 'etiqueta yaguarete flanco
WS.Cells(i, 15).Value = "=@ExtraeDato(""G"",RC[+15])" 'etiqueta yaguarete sexo
WS.Cells(i, 16).Value = "=@ExtraeDato(""H"",RC[+14])" 'etiqueta yaguarete edad
WS.Cells(i, 17).Value = "=@ExtraeDato(""I"",RC[+13])" 'etiqueta yaguarete id Individuo
'
'etiquetas yaguarete------------------------------------------------------------------------------------
'WS.Cells(i, 18).Value = "" 'Identificador del Registro
'WS.Cells(i, 19).Value = "" 'usuario que creo el registro
'WS.Cells(i, 20).Value = "" 'Responsable del Registro
'WS.Cells(i, 21).Value = "" 'Institucion
'WS.Cells(i, 22).Value = "" 'uso libre o reservado
'WS.Cells(i, 23).Value = "" 'uso de la imagen
'WS.Cells(i, 24).Value = "" 'observaciones
'WS.Cells(i, 25).Value = "" 'vivo o muerto
'WS.Cells(i, 26).Value = "" 'animal problema capturado o muerto
WS.Cells(i, 27).Value = "=HYPERLINK(CONCAT(RC[+4],""/"",RC[+12]))"
'
'Enviar al Fondo otros datos-------------------------------------------------------------
WS.Cells(i, 30).Value = objFolder.GetDetailsOf(objFolderItem, 18) ' Keywords o Tags
WS.Cells(i, 31).Value = oFolder.Path 'Folder Path
WS.Cells(i, 32).Value = CDate(objFolder.GetDetailsOf(objFolderItem, 5)) 'Fecha Importacion
WS.Cells(i, 33).Value = objFolder.GetDetailsOf(objFolderItem, 1) ' Tamaño
WS.Cells(i, 34).Value = objFolder.GetDetailsOf(objFolderItem, 164) ' extension
WS.Cells(i, 35).Value = objFolder.GetDetailsOf(objFolderItem, 12) ' Percepcion tipo Archivo
WS.Cells(i, 36).Value = objFolder.GetDetailsOf(objFolderItem, 30) ' Modelo Camara
WS.Cells(i, 37).Value = objFolder.GetDetailsOf(objFolderItem, 32) 'Fabricante Camara
WS.Cells(i, 38).Value = objFolder.GetDetailsOf(objFolderItem, 190) 'nombre folder
WS.Cells(i, 39).Value = oFile.Name 'url
i = i + 1
Call cargadatos_ListaArchivos
On Error Resume Next
Next
End If
application.ScreenUpdating = False
tiempo = datediff("s", tiempo, Now)
MsgBox "La macro dura" & (tiempo)
Unload Me
End Sub
Hola a todos muy buenos dias como estan!
A los grandes maestros de este grupo, queria consultar por una macro que estoy usando para buscar archivos en una carpeta, actualmente la macro me funciona, recorre todos los archivos dentro de una carpeta pero no que no logre es que si hay subcarpetas entre tambien a las sub carpetas, asi que tengo que hacerlo uno por uno
aun asi seleccionando carpeta por carpeta, es muy muy muy lento?.... demora 11 minutos en ejecutarse para evaluar por ejemplo una carpeta con 600 archivos...
me gustaria saber si existe o no una forma de optimizar para que demore menos... porque lo que necesito es evaluar MUUUUCHAS CARPETAS con esa cantidad de contenio o mas.... y voy a demorar la vida...
pero bueno, no se si es posible o no... quizas estaba pensando que si aplico un filtro para que solo me traiga los arhivos de imagen o video, (aunque la carpeta que me duro esa cantidad de tiempo tenia solo imagenes), no se si es el uso del for each lo que hace que sea tan lenta... o si son las formulas que le puse que use con la grabadora de macros: que son de dividir columnas, y de buscar en otra hoja otros datos...
podrian ayudarme a optimizarla por favor? o decirme si es imposible ? ?por favor o si tengo que llegar a la jubilacion ? para evaluarlas a todas jajaja
Tambien pregunto, por las dudas , si es posible mejorar la busqueda, para que no tenga que entrar carpeta por carpeta y pueda incluir la busqueda dentro de subcarpetas?
les comparto el codigo y el archivo, el codigo lo estoy ejecutando en el userform al presionar el boton buscar carpeta...
millones de gracias de antemano a todas las personas que son parte de comunidad que tengas todos un lindo dia!
Private Sub FVBuscarFotosEtiquetas_Click() tiempo = Now 'Declaramos variables Dim FSO As Object, directorio As String Dim dir_Archivo As Variant Dim WS As Worksheet Dim i As Long Dim FolderPath As String Dim objShell, objFolder, objFolderItem As Object Dim oFolder, oFile As Object 'Abrimos ventana de diálogo para seleccionar carpeta Set dir_Archivo = application.FileDialog(msoFileDialogFolderPicker) dir_Archivo.Show 'Si no seleccionamos nada salimos del proceso If dir_Archivo.SelectedItems.Count = 0 Then Exit Sub End If 'Capturamos el directorio del archivo seleccionado directorio = dir_Archivo.SelectedItems(1) 'Creamos objeto y ejecutamos función Carpeta Set FSO = CreateObject("Scripting.FileSystemObject") 'GetFileAttributes FSO.GetFolder(Directorio) application.ScreenUpdating = False Set objShell = CreateObject("Shell.Application") 'D:\PAULA\yaguarete\Jaguar tracker\album tigres FolderPath = directorio '"E:\Yaboti 2021\Aguante Brpy36 14-08-21 E" '"G:\Till\0262529629\" 'Set folderpath Set WS = ActiveWorkbook.Worksheets("FotosEtiquetadas") 'Set sheet name 'WS.Range("A1:O1").Value = Array("URLArchivo", "NombredeArchivo", "Estacion", "Fecha Captura", "Hora", "NombreImagen", "Fecha Importacion", "TipoArchivo", "Tamaño", "PercepcionTipoArchivo", "Etiquetas o Tags", "Sitio", "Estacion", "Especie", "Observaciones") Set FSO = CreateObject("scripting.FileSystemObject") Set oFolder = FSO.getfolder(FolderPath) i = application.CountA(WS.Range("A:A")) + 1 'First row to print result Dim nombrev As String Dim repeticiones As Integer nombrev = oFolder repeticiones = WorksheetFunction.CountIfs(Range("Ae:Ae"), nombrev) If repeticiones > 0 Then MsgBox "La Carpeta ' " & oFolder & " ' ya se encuentra cargada en el sistema.", vbExclamation Else For Each oFile In oFolder.Files On Error Resume Next 'If any attribute is not retrievable ignore and continue Set objFolder = objShell.Namespace(oFolder.Path) Set objFolderItem = objFolder.ParseName(oFile.Name) ' etiquetas del archivo o file ----------------------------------------------------------------------- WS.Cells(i, 1).Value = objFolder.GetDetailsOf(objFolderItem, 0) 'nombre del archiv WS.Cells(i, 2).Value = "=IFERROR(VLOOKUP(CONCAT(RC[3],""-"",RC[1]),'RefEstaciones-Sitios'!C[1]:C[4],4,FALSE),"""")" ' Obtención elementos del ID ------------------------------------------------------------------------- WS.Cells(i, 3).Value = "=@ExtraeDato(""A"",RC[+27])" 'sitio 'WS.Cells(i, 4).Value = "" 'Muestreo Sistemtico WS.Cells(i, 5).Value = "=SepararEnColumnas(RC[-4], 1, "" "")" 'Estacion WS.Cells(i, 6).Value = "=IFERROR(VLOOKUP(CONCAT(RC[-1],""-"",RC[-3]),'RefEstaciones-Sitios'!C[-3]:C[-1],2,FALSE),"""")" 'Latitud WS.Cells(i, 7).Value = "=IFERROR(VLOOKUP(CONCAT(RC[-2],""-"",RC[-4]),'RefEstaciones-Sitios'!C[-4]:C[-2],3,FALSE),"""")" 'Longitud WS.Cells(i, 8).Value = "=IFERROR(SepararEnColumnas(RC[-7], 2, "" ""),"""")" 'FechaCaptura WS.Cells(i, 9).Value = "=IFERROR(SepararEnColumnas(RC[-8], 3, "" ""),"" "")" 'Hora WS.Cells(i, 10).Value = "=@ExtraeDato(""C"",RC[+20])" 'Especie 'WS.Cells(i, 11).Value = "" 'Independizator ' ------------------------------------------------------------------------------------------------------ 'keywords o Tags importados Bridge -------------------------------------------------------------------- WS.Cells(i, 12).Value = "" ' tipo de Registro WS.Cells(i, 13).Value = "=@ExtraeDato(""D"",RC[+17])" 'Observaciones WS.Cells(i, 14).Value = "=@ExtraeDato(""F"",RC[+16])" 'etiqueta yaguarete flanco WS.Cells(i, 15).Value = "=@ExtraeDato(""G"",RC[+15])" 'etiqueta yaguarete sexo WS.Cells(i, 16).Value = "=@ExtraeDato(""H"",RC[+14])" 'etiqueta yaguarete edad WS.Cells(i, 17).Value = "=@ExtraeDato(""I"",RC[+13])" 'etiqueta yaguarete id Individuo ' 'etiquetas yaguarete------------------------------------------------------------------------------------ 'WS.Cells(i, 18).Value = "" 'Identificador del Registro 'WS.Cells(i, 19).Value = "" 'usuario que creo el registro 'WS.Cells(i, 20).Value = "" 'Responsable del Registro 'WS.Cells(i, 21).Value = "" 'Institucion 'WS.Cells(i, 22).Value = "" 'uso libre o reservado 'WS.Cells(i, 23).Value = "" 'uso de la imagen 'WS.Cells(i, 24).Value = "" 'observaciones 'WS.Cells(i, 25).Value = "" 'vivo o muerto 'WS.Cells(i, 26).Value = "" 'animal problema capturado o muerto WS.Cells(i, 27).Value = "=HYPERLINK(CONCAT(RC[+4],""/"",RC[+12]))" ' 'Enviar al Fondo otros datos------------------------------------------------------------- WS.Cells(i, 30).Value = objFolder.GetDetailsOf(objFolderItem, 18) ' Keywords o Tags WS.Cells(i, 31).Value = oFolder.Path 'Folder Path WS.Cells(i, 32).Value = CDate(objFolder.GetDetailsOf(objFolderItem, 5)) 'Fecha Importacion WS.Cells(i, 33).Value = objFolder.GetDetailsOf(objFolderItem, 1) ' Tamaño WS.Cells(i, 34).Value = objFolder.GetDetailsOf(objFolderItem, 164) ' extension WS.Cells(i, 35).Value = objFolder.GetDetailsOf(objFolderItem, 12) ' Percepcion tipo Archivo WS.Cells(i, 36).Value = objFolder.GetDetailsOf(objFolderItem, 30) ' Modelo Camara WS.Cells(i, 37).Value = objFolder.GetDetailsOf(objFolderItem, 32) 'Fabricante Camara WS.Cells(i, 38).Value = objFolder.GetDetailsOf(objFolderItem, 190) 'nombre folder WS.Cells(i, 39).Value = oFile.Name 'url i = i + 1 Call cargadatos_ListaArchivos On Error Resume Next Next End If application.ScreenUpdating = False tiempo = datediff("s", tiempo, Now) MsgBox "La macro dura" & (tiempo) Unload Me End SubPruebaOptimizar.xlsm