Слить несколько файлов .xls в один лист

Question

У меня есть папка, полная файлов .xls, все файлы имеют одинаковую структуру (имена столбцов), я хотел, чтобы код открывал каждый файл в папке и копировал содержимое листа1 и вставить в другой файл первенствует в sheet1, открыть вторую копию файла и добавить в лист 1.

в настоящее время код у меня делает это как другой лист

Sub GetSheets() 
    Path = "C:\Users\dt\Desktop\dt 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 

Answer 1

Это должно сделать трюк:

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:\Users\dt\Desktop\dt 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