Excel - Macro capaz de 'coger' varios archivos

Buenas...
Mi problema es el siguiente, tengo un directorio con varias hojas de excel, de las cuales desdeo varias celdas concretas y pegarlas en una hoja nueva... Al grabar la macro con una lo hace, pero el problema es que tengo mas de 50 ficheros y necesito que la macro, haga esto:
Abrir fichero 1 en ruta c:\copy\1.xls copiar las celdas necesarias y copiarla en el fichero 'new.xls'
Abrir fichero a en ruta c:\copy\a.xls copiar las celdas necesarias y copiarla en el fichero 'new.xls'
He buscado en el foro y aconsejan que le de una variable a cada libro, pero el problema es que cada 3 meses se ha de hacer esto y los nombres cambian, entonces siempre deberia estar retocando la macro para cambiar los nombres de las variables
¿hay alguna manera de decirle en una macro (o visual) que habra todos lo ficheros *.xls de un directorio, coger las celdas que necesito y pegarlas en una nueva hoja ( al abrir la 1.xls, pege las celdas en la fila 1 del fichero new.xls, cierre el 1.xls, abra el a.xls y copie las celdas en la siguiente linea, cierre el a.xls y asi sucesivamente)
Gracias y Felices Fiestas

Hace bastante tiempo hice esto... espero que lo puedas adaptar o te sirva
de idea...
No tengo tiempo sino te lo haría...

Attribute VB_Name = "Agrupar_archivos"
Option Explicit
Option Private Module

'AgruparArchivos 29/05/2004 by JuanC"

Const FILE_NAME_DEST = "RESUMEN.XLS"
Const FILE_DEST = "C:\LISTAS PRECIOS\RESUMEN.XLS"
Const DIR_ORIGEN = "C:\LISTAS PRECIOS"
Const EXT = "*.xls"

Sub AgruparArchivos()
Dim i%, s$, oldStatusBar$
Dim ws
On Error Resume Next
Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Procesando archivos..."

'Busca archivos de origen (sin procesar)
If Not BuscarOrigen(False) Then
MsgBox "No hay listas de precios disponibles.", vbExclamation
GoTo fin 'Si no encontró archivos termina
End If
'Abre y vacía Destino
PrepararDestino
'Busca y procesa (copia todas las hojas en Destino)
BuscarOrigen (True)
'Elimina la primer hoja del archivo Destino
Workbooks(FILE_NAME_DEST).Sheets(1).Delete
'Activa la primer hoja del archivo destino
Workbooks(FILE_NAME_DEST).Sheets(1).Activate
'Guarda archivo Destino
Workbooks(FILE_NAME_DEST).Save
fin:
'Activa nuevamente la pregunta para permitir eliminar una hoja
Application.DisplayAlerts = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
End Sub

Private Sub PrepararDestino()
Dim ws
On Error Resume Next
'Si el libro actual no es el Destino
If StrConv(ThisWorkbook.Name, vbUpperCase) <> FILE_NAME_DEST Then
'Abre el archivo
Workbooks.Open Filename:=FILE_DEST
End If
'Para que no pregunte si desea eliminar la hoja
Application.DisplayAlerts = False
'Elimina todas las hojas (menos una)
For Each ws In Worksheets
Worksheets(ws.Name).Delete
Next ws
'Limpia la única hoja que queda
Cells.Clear
'Cambia el nombre
Worksheets(1).Name = "FENIX"
Set ws = Nothing
End Sub

Private Sub Procesar(FName As String)
Dim w, i%, N$, s$
On Error Resume Next
'Abre el archivo origen
Workbooks.Open Filename:=FName

N = FName
N = Right(N, Len(N) - InStrRev(N, "\"))
N = Left(N, Len(N) - (Len(N) - InStrRev(N, ".")) - 1)

If Len(N) > 10 Then N = Left(N, 10)

For i = 1 To Sheets.Count
s = Worksheets(i).Name
Sheets(i).Name = N & s 'Renombra todas las hojas
Next

'Selecciona todas las hojas del libro origen
Sheets.Select
'Copia todas las hojas al final del libro Destino
Sheets.Copy After:=Workbooks(FILE_NAME_DEST).Sheets(Workbooks(FILE_NAME_DEST).Sheets.Count) 'Before:=.Sheets(1)
'Cierra archivo
For Each w In Workbooks
If StrConv(DIR_ORIGEN & "\" & w.Name, vbUpperCase) = StrConv(FName, vbUpperCase) Then
w.Close savechanges:=False
End If
Next w
Set w = Nothing
End Sub

Private Function BuscarOrigen(P As Boolean) As Boolean
Dim fs, i%
On Error Resume Next
Set fs = Application.FileSearch
BuscarOrigen = False
With fs
.LookIn = DIR_ORIGEN
.Filename = EXT
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
BuscarOrigen = True
If Not P Then Exit Function 'Si no debe procesar termina
For i = 1 To .FoundFiles.Count
If StrConv(.FoundFiles(i), vbUpperCase) <> FILE_DEST Then
Procesar .FoundFiles(i) 'Abre origen y copia sus hojas al Destino
End If
Next i
End If
End With
Set fs = Nothing
End Function

Saludos desde Baires, JuanC

Pedazo de script......
Creo que me he liado un poco con mi explicacion sobre mi problema....
Simplicando... necesito una macro (o codigo en visual) que de un directorio, me abra distintos libros, coja de todos ellos el valor de la celda A1 (por ejemplo) y me lo pege un nuevo fichero de excel, saltando de linea a cada nueva celda A1 de los distintos ficheros..
No consigo hacer funcionar tu codigo :-P Pero muchas gracias juan

Aqui pongo un ejemplo del codigo, con el problema de que tengo que cambiar todas las rutas manualmente
Sub Macro2()
'
' Macro2 Macro
' Macro grabada el 29/12/2006 por *
'

'
Workbooks.Open Filename:= _
"C:\Documents and Settings\usuario\Escritorio\OCTUBRE CAPI\BICI O CON 1.xls"
Range("H12").Select
Selection.Copy
Windows("hacienda.xls").Activate
Range("C6").Select
ActiveSheet.Paste
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Windows("BICI O CON 1.xls").Activate
Range("F12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("E6").Select
ActiveSheet.Paste
Windows("BICI O CON 1.xls").Activate
Range("F6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("F6").Select
ActiveSheet.Paste
Range("G5").Select
Application.CutCopyMode = False
Selection.Copy
Range("G6").Select
ActiveSheet.Paste
Range("D5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("D5:D6"), Type:=xlFillDefault
Range("D5:D6").Select
Range("B5").Select
Selection.AutoFill Destination:=Range("B5:B6"), Type:=xlFillDefault
Range("B5:B6").Select
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
Windows("BICI O CON 1.xls").Activate
ActiveWindow.SmallScroll Down:=12
Range("H43").Select
Selection.Copy
Windows("hacienda.xls").Activate
Range("J6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("BICI O CON 1.xls").Activate
Range("H42").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("I6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("H5:H6"), Type:=xlFillDefault
Range("H5:H6").Select
Range("I12").Select
Windows("BICI O CON 1.xls").Activate
ActiveWindow.Close
Workbooks.Open Filename:= _
"C:\Documents and Settings\usuario\Escritorio\OCTUBRE CAPI\FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls"
Windows("hacienda.xls").Activate
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
Range("H12").Select
Selection.Copy
Windows("hacienda.xls").Activate
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C7").Select
ActiveSheet.Paste
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
Range("F12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("E7").Select
ActiveSheet.Paste
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
Windows("hacienda.xls").Activate
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
Range("F6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("F7").Select
ActiveSheet.Paste
Range("B6").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("B6:B7"), Type:=xlFillDefault
Range("B6:B7").Select
Range("D6").Select
Selection.AutoFill Destination:=Range("D6:D7"), Type:=xlFillDefault
Range("D6:D7").Select
Range("G6").Select
Selection.AutoFill Destination:=Range("G6:G7"), Type:=xlFillDefault
Range("G6:G7").Select
ActiveWindow.ScrollColumn = 2
Range("H6").Select
Selection.AutoFill Destination:=Range("H6:H7"), Type:=xlFillDefault
Range("H6:H7").Select
ActiveWindow.ScrollColumn = 3
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
ActiveWindow.SmallScroll Down:=21
Range("H43").Select
Selection.Copy
Windows("hacienda.xls").Activate
Range("J7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
Range("H42").Select
Application.CutCopyMode = False
Selection.Copy
Windows("hacienda.xls").Activate
Range("I7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FACTURA FORUM ELCHE (CEN. COM. L`ALJUB ).xls").Activate
ActiveWindow.Close
End Sub

Bueno, creo que voy progresando....
Con este codigo, consigo que salga un listado de los ficheros de un directorio, pero ahora me falta saber, como le asigno una variable distinta a cada una de las celdas devueltas (ya que me pone la ruta), de manera automatica

Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Sub ListFiles()
Dim Msg As String
Dim Directory As String
Dim R As Long, X As Long
Dim C As Long
Application.StatusBar = "Esta macro puede tardar varios minutos"
Msg = "Selecciona el directorio que contiene los Ficheros Necesarios:"
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
R = Cells(65536, Range("PTSOurce").Cells(1).Column).End(xlUp).Offset(1, 0).Row
C = Range("PTSOurce").Cells(1).Column
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Directory
If Range("Extension").Value = "" Then
.Filename = "*.*"
Else
.Filename = "*." & Range("Extension").Value
End If
If LCase(Range("SubFicheros").Value) = "si" Then
.SearchSubFolders = True
Else
.SearchSubFolders = False
End If
.Execute
For X = 1 To .FoundFiles.Count
Cells(R, C) = Application.WorksheetFunction.RoundDown((FileLen(.FoundFiles(X)) / 1048656.21374046), 0) '1048656 '1000
Cells(R, C + 1) = .FoundFiles(X)
Cells(R, C + 2) = Mid(.FoundFiles(X), Len(Directory) + 1) ', Len(Directory))
R = R + 1
If R > 65500 Then Exit For
Next X
End With
Application.StatusBar = ""
MsgBox "Listo"
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long
Dim X As Long
Dim pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
Path = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub Borrar()
Dim Rg As Range
Set Rg = ActiveSheet.Range("PTSource").CurrentRegion
Set Rg = Rg.Offset(1, 0)
Rg.ClearContents
End Sub

Esto es un poco chapuzas, pero bueno......
Renombro los ficheros con formato: Factura 1, Factura 2, Factura 3, etc
Con este codigo deberia, copiar una hoja, pero al ejecutarlo me da el error:
Error 1004
Error en el metodo 'open' de objeto 'worbooks'
(Luego ya añadire el codigo para que solo copie determinadas celdas y no la hoja entera)

Sub Summarize()

Dim Counter As Long
Dim Source As Workbook
Dim Dest As Workbook

Const MyDir As String = "c:\temp\"

Application.ScreenUpdating = False

For Counter = 1 To 100
Set Source = Workbooks.Open(MyDir & "Book" & Counter & ".xls")
If Counter = 1 Then
Source.Worksheets("Sheet1").Copy
Set Dest = ActiveWorkbook
ActiveSheet.Name = Counter
Else
Source.Worksheets("Sheet1").Copy After:=Dest.Worksheets(Dest.Worksheets.Count)
Dest.Worksheets(Dest.Worksheets.Count).Name = Counter
End If
Source.Close False
Next

Dest.SaveAs MyDir & "Summary.xls"

Application.ScreenUpdating = True

MsgBox "Done"

End Sub

Bueno con el codigo en si no te puedo ayudar, pero te puedo dar la idea, asi que te tocara plazmarla.

Bueno primordial te recomiendo que los archivos que vayas a leer los tengas en una carpeta, pero que solamente esten esos.
Luego haces como una especie de buscador, digamos pones una ventana de seleccion de carpeta donde estan los archivos. haces el proceso para obtener los nombres con las rutas de los archivos y los pones dentro de un vector o de repente usas dos vectores, unos para usar el libro con la ruta completa y otro solo para el nombre del libro, ya que en excel solo se manejan los libros luego de abiertos con solo el nombre.

bueno tienes la ruta con su nombre, y la vas asigando a un vector dinamico y te recomiendo que uses preserve para irlo aumentando ya que no sabes cuantos archivos hay, o si los cuentas primeros la dimensionas completa de un vez.

para obtener el nombre de un libro solamente yo hice esto

NomLibro = Right(ROOTFILE, Len(ROOTFILE) - InStrRev(ROOTFILE, "\"))

y para lo de las variables tambien usa son matrices, asi puedes hacer digamos, una columna de la Matriz para todos los datos de las COLUMNA A de las hojas de los libros, otra para la B y asi hasta que tenga todas.

un punto va a ser las hojas de un libro, cuando lo abres vas a tener que saber a que hoja le vas a extraer los datos, es facil si siempre se va a tener el mismo nombre la hoja, digamos "DATOS", sheet("DATOS").select
o bien si vas a usar todas las hojas del libro qeu abras tendras que poner un ciclo para las hojas

For Each WS in Worksheets
NombreHoja= WS.name

Sheets(NombreHoja).select

procesos etc.

Next

en el caso de que tengas que usar varias hojas y digamos que siempre son la misma cantidad en todos los libros a abrir, tendras que dimensionar una matriz de tres dimensiones, asi podras hacer, M( n,n,1) para la hoja 1, M(n,n,2) para la hoja 2, y asi te vas.

Espero te sirva de algo mi pequeño aporte.

Hola Juan Carlos

Sabes? ando en algo parecido... pudiste al final lograr obterne de diferentes archivos con nombres diferentes la información a capturar...

Me puedes compartir tu macro si lo lograste???

Saludos y gracias