Importing worksheets into one excel workbook - excel

Question

I have a folder with 111 excel work books. I want to copy and paste every file into one excel file into separate sheets. So one sheet should have the contents of one file. Each file contains only one sheet. Any ideas would help as i am not very familiar with VBA. And I don't want to copy and paste 111 times.
Thanks.

Answer 1

I had the same issue recently. This code is all you need. Specify a folder and it will combine all workbooks into one (handles them even if they have multiple sheets, too).
' found at: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829
Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long
Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer
'Root folder = Desktop
bInfo.pIDLRoot = 0&
'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Please select the folder of the excel files to copy."
Else
bInfo.lpszTitle = msg
End If
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As range
Dim Wkb As Workbook
Dim ws As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each ws In Wkb.Worksheets
Set LastCell = ws.cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = range("$A$1").Address Then
Else
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
End If
Next ws
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub

Answer 2

This is a shorter version. You'll need to do Tools/References and add Microsoft Scripting Runtime.
Sub CopySheet1s()
' Copies first sheet from all workbooks in current path
' to a new workbook called wbOutput.xlsx
Dim fso As New Scripting.FileSystemObject
Dim vFile As Variant, sFile As String, lPos As Long
Dim wbInput As Workbook, wbOutput As Workbook
Dim fFolder As Folder
Const cOUTPUT As String = "wbOutput.xlsx"
If fso.FileExists(cOUTPUT) Then
fso.DeleteFile cOUTPUT
End If
Set wbOutput = Workbooks.Add()
Set fFolder = fso.GetFolder(ThisWorkbook.Path)
For Each vFile In fFolder.Files
lPos = InStrRev(vFile, "\")
sFile = Mid(vFile, lPos + 1)
If sFile <> cOUTPUT And sFile <> ThisWorkbook.Name And Left(sFile, 1) <> "~" Then
Set wbInput = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
wbInput.Worksheets(1).Copy after:=wbOutput.Worksheets(1)
wbInput.Close savechanges:=False
End If
Next
wbOutput.SaveAs Filename:=cOUTPUT
wbOutput.Close
End Sub

Answer 3

Place all your .xls files into one folder, enter the files path in 'Enter Files Path Here' and run the macro.
Sub GetSheets()
Path = "C:\Enter Files Path Here\"
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