Спасибо, но мне нужен не список раздела или файлов в папке, а чтобы в один файл xls были записаны значения из файлов в папке (к примеру d:\папка\*.xls). При условие что в этих файлах заполенны только 3 ячейки a1:c1.
d:\папка\1.xls 1 a 4
d:\папка\2.xls 6 d 2
...

итог.xls
1 a 4
6 d 2
я уже пробовал вот это http://www.sql.ru/forum/actualthread.aspx?tid=236239
только видно у меня руки кривые.
----------------------------------------
Sub vv()


Dim objBook As Excel.Workbook 'çàâîäèòñÿ ïåðåìåííàÿ äëÿ îòêðûòèÿ äîêóìåíòà
Dim objSheet As Excel.Worksheet 'çàâîäèòñÿ ïåðåìåííàÿ äëÿ ñòðàíèöû
Dim z%, i%, j%
Dim xxx$, xx$

Set NewSheet = ActiveSheet

j = 1
xx = "A" + Trim(Str(j + 1))
With Application.FileSearch
.NewSearch
.LookIn = "d:\1"
.SearchSubFolders = False
.Filename = "1"
.MatchTextExactly = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set objBook = Workbooks.Open("d:\1\1.xls")
Set objSheet = objBook.Worksheets(1)
i = 1
Do While objSheet.Cells(i + 1, 1) <> ""
i = i + 1
Loop
j = j + i - 1
xxx = "A1:C" + Trim(Str(i))
objSheet.Range(xxx).Copy
NewSheet.Paste Destination:=NewSheet.Range(xx)
xx = "A" + Trim(Str(j + 1))
objBook.Close
End If
End With

With Application.FileSearch
.NewSearch
.LookIn = "d:\1"
.SearchSubFolders = False
.Filename = "4"
.MatchTextExactly = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set objBook = Workbooks.Open("d:\1\4.xls")
Set objSheet = objBook.Worksheets(1)
i = 1
Do While objSheet.Cells(i + 1, 1) <> ""
i = i + 1
Loop
j = j + i - 1
xxx = "A1:C" + Trim(Str(i))
objSheet.Range(xxx).Copy
NewSheet.Paste Destination:=NewSheet.Range(xx)
xx = "A" + Trim(Str(j + 1))
objBook.Close
End If
End With

End Sub
------------------------
Показывает только данные последнего файла. Подскажите что не так?

Народ, у кого проблемы с vba, как у меня, но есть немного знания английского рекомендую пользоваться поиском на англоязычных сайтах инфы валом, нашел через поиск yahoo.com за 10 минут.
----------------------------------------------------
Sub Example5()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim SourceRcount As Long
Dim N As Long
Dim rnum As Long
Dim MyPath As String
Dim SaveDriveDir As String
Dim FName As Variant

SaveDriveDir = CurDir
MyPath = "D:\1" 'сюда пишем где файлы лежат и все
ChDrive MyPath
ChDir MyPath

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _
MultiSelect:=True)
If IsArray(FName) Then
Application.ScreenUpdating = False
Set basebook = ThisWorkbook

For N = LBound(FName) To UBound(FName)
Set mybook = Workbooks.Open(FName(N))

rnum = LastRow(basebook.Worksheets(1)) + 1

Set sourceRange = mybook.Worksheets(1).Range("A1:C1")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want

sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only the values

' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _
' Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value

mybook.Close False

Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function