Bom dia!!

Leia:
http://msdn.microsoft.com/en-us/library/cc837974.aspx

Sub Favor_Adaptar()
    Dim p, f, s, a, r
    p = "C:SuaPasta"
    f = Dir(p & "*.xls")
    s = "SuaGuia1"
    a = "A1"
    Do While f <> ""
        r = r + 1
        Range("A" & r) = GetValue(p, f, s, a)
        f = Dir()
    Loop
End Sub

Sub OU_65900()
    Dim FileName As String, FileSpec As String, FileFolder As String
    Dim wb As Workbook
    Dim dblSum As Double, fn As String
    
    dblSum = 0
     
    FileFolder = ThisWorkbook.Path
    FileSpec = FileFolder & "test*.*"
     
    FileName = Dir(FileSpec)
    If FileName = "" Then Exit Sub
     
    Do While FileName <> ""
        If IsWorkbookOpen(FileName) = False Then
            'Set wb = Workbooks.Add(FileFolder & FileName)
            'DoEvents
            dblSum = dblSum + (GetInfoFromClosedFile(FileFolder, FileName, "Sheet1", "A1"))
            'wb.Close True
        End If
        FileName = Dir()
    Loop
    
    MsgBox dblSum
End Sub
 
Function IsWorkbookOpen(stName As String) As Boolean
    Dim Wkb As Workbook
    On Error Resume Next
    Set Wkb = Workbooks(stName)
    If Not Wkb Is Nothing Then IsWorkbookOpen = True
     'Boolean Function assumed To be False unless Set To True
End Function

'=GetValue("c:files", "budget.xls", "Sheet1", "A1")
'    wbPath = "d:files"
'    wbName = "budget.xls"
'    wsName = "Sheet1"
'    cellRef = "A1:R30"
Private Function GetInfoFromClosedFile(ByVal wbPath As String, wbName As String, wsName As String, cellRef As String) As Variant
    Dim arg As String
    GetInfoFromClosedFile = ""
    If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
    If Not FileExists(wbPath & "" & wbName) Then Exit Function
    arg = "'" & wbPath & "[" & wbName & "]" & wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

Function FileExists(sFilename As String) As Boolean
  Dim fso As Object, tf As Boolean
  Set fso = CreateObject("Scripting.FileSystemObject")
  tf = fso.FileExists(sFilename)
  Set fso = Nothing
  FileExists = tf
End Function

Att

Muito Obrigado por ser tão prestativo.

Eu usei o código do link da microsoft, deu certo, porém ele resulta todos os valores com os nomes da pasta de trabalho, eu queria somente o valor.

O seu primeiro código não consegui adaptar, e o segundo não entendi.

Se quiser auxiliar com sua primeira citação, parece ser o que eu preciso, além de ser simples.

Esquecendo a mensagem acima, menos a parte do prestativo, anulei a função que puxa todos os nomes.
Mas queria agrupar todos os valores em uma só célula, em vez de um por linha, tem como você achar o comando pra mim?
Outra coisa, como faz pra ele puxar os valores para a pasta de trabalho que uso o comando? Ele está criando uma nova.

Pra fazer vários comandos desses, uso somente um comando e um botão, vários comandos e um botão, vários comandos e vários botões???

Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

' Change this to the pathfolder location of your files.
MyPath = "C:Documents and SettingsAgriculturaDesktopPEDIDO MUDASPedidosBloco"

' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If

' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then
On Error Resume Next

' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("L87")
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Copy the file name in column A. Desnecessário
'With sourceRange
' BaseWks.Cells(rnum, "A"). _
' Resize(.Rows.Count).Value = MyFiles(FNum)
'End With Desnecessário

' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)

' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next FNum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Uma ideia... como faço para gerar em linhas em vez de colunas????

Desculpe os posts repetidos...