Extraer datos de archivos excel almacenados en carpeta

Tengo el siguiente código, que me sirve pero para que funciono debe guardar como el archivo excel, y extrae la información de los libros con el nombre de la hoja definido, pero necesito que no cada vez que abra el libro dar guardar como:

Sub copia_hojas()
On Error Resume Next
Sheets("BASE").Select
hoja = "Consulta"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mi = ThisWorkbook.Name
Set H1 = ThisWorkbook.Sheets("BASE")
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Do While archi <> ""
If archi <> mi Then
Workbooks.Open archi
If Err.Number = 0 Then
uf = H1.Range("A1").SpecialCells(xlLastCell).Row + 1
Sheets(hoja).Select
wnum = Err.Number
Sheets(hoja).UsedRange.Select
Selection.Copy H1.Cells(uf, "A")
Workbooks(archi).Close
Cells.Select
Selection.UnMerge
End If
Err.Number = 0
End If
archi = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Proceso de copiar hojas, Terminado", vbInformation, ""
End Sub

saludos