Optimizar Consolidación de archivos en VBA
¿Cómo están?
Espero que bien, les cuento tengo una macro que consolida archivos en función a dos parámetros (ruta de archivos y ubicación de nombre de archivo), esta macro consolida y luego selecciona el nombre de la carpeta que lo contiene para agregarlo como una columna al inicio. Hasta ahí todo bien, inicialmente eran 500 archivos, pero ahora son aproximadamente 1200 archivos y este procesodura una hora, por lo que pido su ayuda para optimizar el tiempo.
Aqui el codigo:
Function BuscarHoja1(nombreHoja As String) As Boolean
Dim i
For i = 1 To Worksheets.Count
If Worksheets(i).Name = nombreHoja Then
BuscarHoja1 = True
Exit Function
End If
Next
BuscarHoja1 = False
End Function
Sub DoFolder(Folder)
Dim SubFolder
Dim ruta
Dim PrimeraCelda As Long ' captura el valor de la primera celda vacia
Dim UltimaFila As Long 'captura el valor de la ultima fila
Dim StorePath() As String
Dim StoreName As String
'---
Dim rowita 'Almacena el numero de filas actuales para quitar encabezado
Dim columnita 'Almacena el numero de columas actuales para quitar encabezado
Dim celdapegado
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
Dim flDate As Date
If Left(File.Name, 2) = "VE" And Right(File.Name, 4) = ".DBF" Then
cuentaarchivos = cuentaarchivos + 1
Debug.Print File.Path
StoreName = File.Path
StorePath = Split(StoreName, "\")
StoreName = StorePath(UBound(StorePath) - UserForm1.numero)
Debug.Print StoreName
Workbooks.OpenText Filename:=(File.Path)
[BaseDeDatos].Select
'declaro las variables para que cumplan aqui en esta seleccion
rowita = Selection.Rows.Count 'Cuenta el numero de filas seleccionadas
columnita = Selection.Columns.Count 'Cuenta el numero de columnas seleccionadas
'Si las filas de la tabla a copiar
If rowita > 1 Then Range(Cells(2, 1), Cells(rowita, columnita)).Select
If rowita <= 1 Then Range(Cells(2, 1), Cells(2, 16)).Select
Selection.Copy
ruta = ActiveWorkbook.Path
Workbooks(ESTELIBRO).Activate
celdapegado = Range("A1048576").End(xlUp).Row + 1
Cells(celdapegado, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Revisar si en la A1 hay algo y que desplace hasta buscar
Workbooks(ESTELIBRO).Activate
PrimeraCelda = Range("A1048576").End(xlUp).Row + 1 ' Las propiedades se guardan en variables
'Hacer el recorrido para saber la ultima fila
UltimaFila = Range("B1048576").End(xlUp).Row ' Las propiedades se guardan en variables
'selecciona el rango vacio de la primera columna
'Rango (Primera celda, ultima fila de la columna a), y lo iguala al valor de la variable tienda
If rowita > 1 Then Range(Cells(PrimeraCelda, 1), Cells(UltimaFila, 1)).Value = StoreName
'-------------
Application.DisplayAlerts = False
Workbooks(File.Name).Close
End If
Next
End Sub
