Necesito recorrer abrir todos los libros de un directorio, abrirlos y copiar un rango en otro libro.

He hecho esta macro. Pero no recorre el directorio. Sólo me abre el primer libro

¿cómo se debería hacer???

Sub ImputaTodas()
'Esta macro intenta imputar todas la hojas de un mes
Dim NombreArchivo, Directorio, Mes As String
'Detecto de qué directorio quiero leer las hojas.
Mes = ActiveSheet.Range("D3").Value

NombreArchivo = Dir("Z:\CALIDAD\PERSONAL\Control_horas\" & Mes & "\*.xlsm")

Do While NombreArchivo <> ""
'Recorre el directorio elegido buscando los archivos .xlsm"
NombreArchivo = Dir("Z:\CALIDAD\PERSONAL\Control_horas\" & Mes & "\*.xlsm")
'Abre el libro fuente
Workbooks.Open Filename:=NombreArchivo
'Seleciona una hoja y un rango
Sheets("DATOS").Select
Range("A7:K1000").Select
Selection.Copy
'Abre el libro Destino donde están las tablas y activa la hoja "Suma"
Workbooks.Open Filename:= _
"Z:\CALIDAD\PERSONAL\Control_horas\Consolidacion_hojas.xlsx", UpdateLinks:=3
Sheets("SUMA").Select
'Busca la ultima celda rellena y baja una fila (este es um método chapucero pero rápido de programar)
Range("B1").Select
Selection.End(xlDown).Select
'Baja uan fila y retrocede una columna
ActiveCell.Offset(1, -1).Activate
'Copia lo selecionado
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Salva y cierra el libro destino
ActiveWorkbook.Save
ActiveWorkbook.Close
'Cierra el libro fuente
ActiveWorkbook.Close
If NombreArchivo = "" Then Exit Do

Loop
End Sub

Ahora me doy cuenta que abriría el libro destino y lo cerraría cada vez.. ya, ya se que eso está mal. Mi pregunta es cómo hag para que recorra todo el directorio. Y luego Como activo un libro u otro??