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