Reputation: 1829
I have a folder full of .xls files, all the files have the same structure (column names), I wanted the code to open each file in the folder and copy the contents of sheet1 and paste in another excel file into sheet1, open the second file copy and append in sheet 1.
Currently the code I have does this as different sheet
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
Upvotes: 1
Views: 8940
Reputation: 14547
This should do the trick :
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
'OR
.Range("A" & WriteRow).PasteSpecial
End With
'''To clear clipboard to avoid 'large clipboard' warnings on close
Application.CutCopyMode = False
WbSrc.Close
Filename = Dir()
Loop
End Sub
Upvotes: 3