Как в VBA (Excel 2007) первые листы всех XLS файлов в папке перенести в один XLS файл?

По очереди открываете все листы, копируете лист, вставляете в результирующий файл в новый лист. Относительно несложно, но может профукатся ширина колонок и чето еще по мелочи.
На VBA за полчасика можно нарисовать.

Код макроса

Sub Macros()
Set wshell = CreateObject("Shell.Application")
On Error Resume Next
Set iPath = wshell.BrowseForFolder(0, " Выберите папку.... ", &H4000, "C:\")
If Not iPath Is Nothing Then
FolderPath = iPath.Items.Item.Path
FileAllSheet = InputBox("Выбрать имя файла, " & Chr(10) & "в который копировать все листы", "Выбор имени файла", "all_sheets.xls")
If FileAllSheet = "" Then End
Dim xlallsh As Excel.Workbook
Dim xlonesh As Excel.Workbook
Workbooks.Add xlWBATWorksheet
ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\" & FileAllSheet)
Set xlallsh = ActiveWorkbook
XlsPath = FolderPath & "\" & "*.xls" 'Установка пути к файлам.
Application.ScreenUpdating = False
XlsName = Dir(XlsPath) 'Читает первый файл.
Do While XlsName <> ""
Set xlonesh = Workbooks.Open(FolderPath & "\" & XlsName)
If i <> Empty Then xlallsh.Sheets.Add After:=xlallsh.Sheets(xlallsh.Sheets.Count)
xlallsh.Sheets(xlallsh.Sheets.Count).Name = xlonesh.Name
i = xlonesh.Sheets(1).Cells.Copy(xlallsh.Sheets(xlallsh.Sheets.Count).Cells)
xlonesh.Close
XlsName = Dir 'перейти к следующему файлу.
Loop
Application.ScreenUpdating = True
xlallsh.Save
End If
End Sub

Сразу скажу это не мой макрос, где-то сдернул в инете, но работает практически так как ты хочешь, после запуска макроса он запросит папку в которой надо провести сбор листов, в папке выделяешь все листы и все.. .

Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer

On Error GoTo ErrHandler
Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Files to Merge")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла! "
GoTo ExitHandler
End If

x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
Sheets().Move After:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub