将多个.xls文件合并到一个工作表中

我有一个完整的.xls文件的文件夹，所有的文件都有相同的结构（列名），我希望代码打开文件夹中的每个文件，复制sheet1的内容并粘贴到另一个excel文件中，打开第二个文件复制并追加到表单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