Macro juntar varios archivos y crear un nuevo archivo

Que tal a todos.

Soy nuevo en este foro. Solicito de su apoyo y amable cooperación para realizar un macro el cual su funcion sea la siguiente:

Tengo una carpeta con mas de 1000 archivos .xls los cuales quiero unir es un nuevo archivo de excel; los archivos tienen las mismas columnas, el problema es que el rango en cada archivo es variable.

En el archivo Juntar.xls tengo lo que llevo de la macro, podrian ayudarme a solucionar este problema.

Option Explicit

Sub LlenaCuadros()
Dim wb As Workbook
Dim strArchivoExcel As String
Dim strNombreCarpeta As String

strNombreCarpeta = PonDiag(ActiveWorkbook.Path)

'preparar carpeta
ChDir strNombreCarpeta
strArchivoExcel = Dir("*.xls")

'repasamos los archivos de la carpeta
Do While strArchivoExcel <> ""
Set wb = Workbooks.Open(strNombreCarpeta & "\" & strArchivoExcel)
  MsgBox wb.ActiveSheet.Cells(1, 1)
wb.Close False
Set wb = Nothing
strArchivoExcel = Dir
Loop

End Sub

Function PonDiag(Path As String) As String
'Devuelve Path agregándole la diagonal final si lo necesita.
  PonDiag = IIf(Right(Path, 1) = "\", Path, Path & "\")
End Function
[/code]

De antemano gracias.

Saludos.

macro.rar

Juntar.xls

macro.rar

Juntar.xls