Macro Abrir Archivo por Archivo de un Fichero, y Llenar celda vacía

Tengo 500 archivos que son exactamente iguales en su estructura, quiero abrir archivo por archivo y por ejemplo en la celda M11 de la HOJA1, pegar los últimos 10 dígitos del nombre de cada archivo .

¿Es posible hacerlo?

Cual sera la mejor Opción de realizarlo, ya que tengo este código: pero siento que tarda un poco en este código, se borra el contenido de la celda a1, la verdad no se como decirle que pegue los últimos 10 dígitos del nombre de cada archivo.

Gracias!..

Sub AbrirArchivos()
Dim ruta, archivos As String

ruta = MiRuta
archivos = Dir(ruta & "\*.xlsx*")
Do While archivos <> “”
Workbooks.Open ruta & "\" & archivos
Range("a1").ClearContents
MsgBox ActiveWorkbook.Name
ActiveWorkbook.Close SaveChanges:=True
archivos = Dir
Loop
End Sub
Function MiRuta()
Dim directorio As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Seleccionar Carpeta"
.Show
directorio = .SelectedItems(1)
End With
If directorio <> "" Then
MiRuta = directorio
End If
End Function