Обединете няколко .xls файла в един лист - excel, vba, excel-vba, merge

Имам пълна папка.xls файлове, всички файлове имат една и съща структура (имена на колони), исках кодът да отвори всеки файл в папката и да копира съдържанието на sheet1 и да го поставите в друг excel файл в sheet1, да отворите второто копие на файла и да го добавите в лист 1.

В момента кодът, който имам, прави това като различен лист

  Sub GetSheets()
Path = "C:UsersdtDesktopdt kte"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Отговори:

Това трябва да свърши работа:

Sub GetSheets()
Dim WriteRow As Long, _
LastCell As Range, _
WbDest As Workbook, _
WbSrc As Workbook, _
WsDest As Worksheet, _
WsSrc As Worksheet

Set WbDest = ThisWorkbook
Set WsDest = WbDest.Sheets.Add
WsDest.Cells(1, 1) = "Set your headers here"

Path = "C:UsersdtDesktopdt kte"
Filename = Dir(Path & "*.xls")

Do While Filename <> ""
Set WbSrc = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
Set WsSrc = WbSrc.Sheets(1)
With WsSrc
Set LastCell = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
.Range(.Range("A1"), LastCell).Copy
End With
With WsDest
WriteRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
.Range("A" & WriteRow).Paste
End With

WbSrc.Close
Filename = Dir()
Loop

End Sub