Combine first sheet of multiple workbooks into one workbook - excel

I have a macro to combine different workbooks into one master Excel workbook:
Sub GetSheets()
Path = "\Users\myname\Documenten\Test\"
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
How would I include only the first worksheet of each workbook into the master workbook?
How would I rename the worksheets to the name of the workbook it comes from?


try this:
Option Explicit
Sub GetSheets()
Dim Path As String, fileName As String
Dim Sht As Worksheet
Path = "\Users\myname\Documenten\Test\"
fileName = Dir(Path & "*.xls")
Do While fileName <> ""
Workbooks.Open fileName:=Path & fileName, ReadOnly:=True
With ActiveWorkbook
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets(2).name = .name
End With
ActiveWorkbook.Close
fileName = Dir()
Loop
End Sub


Sub GetSheets()
Dim Path As String, fileName As String
Dim Sht As Worksheet
Path = "\somepath\"
fileName = Dir(Path & "*.xls")
Do While fileName <> ""
Workbooks.Open fileName:=Path & fileName, ReadOnly:=True
With ActiveWorkbook
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
End With
Workbooks(fileName).Close
fileName = Dir()
Loop
End Sub

Related

VBA to Combine Tabs (with similar names) from Different Excel Workbooks, each With Multiple Tabs

I have about 50 xlsx files in a folder that have three tabs: 1. Active, 2. Active Change, and 3. Suspended. I want to combine all the tabs with names similar to "Suspended" into one workbook. I keep getting syntax errors in the 7th line of code, "For Sheets...". Any help rectifying this would be greatly appreciated!
Sub GetSheets()
Path = "C:\Users\Tracy Anderson Dell\Dropbox\Memberships & Subs Tracking\MBO\Membership\59th Street\"
Filename = Dir(Path & ".xlsx")
strSheetName = "Suspended"
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Sheets(strSheetName).Select In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Declare your variables and create a workbook variable then just copy the sheet without the worksheet loop.
Sub GetSheets()
Dim path As String
path = "C:\Users\Tracy Anderson Dell\Dropbox\Memberships & Subs Tracking\MBO\Membership\59th Street\"
Dim fileName As String
fileName = Dir(path & ".xlsx")
Dim strSheetName As String
strSheetName = "Suspended"
Do While fileName <> ""
Dim wkb As Workbook
Set wkb = Workbooks.Open(fileName:=path & fileName, ReadOnly:=True)
wbk.Worksheets(strsheename).Copy After:=ThisWorkbook.Sheets(1)
wkb.Close
fileName = Dir()
Loop
End Sub

Get sheetname while importing excel sheet?

I would like to get the sheetname after I imported it excel workbook.
Below I was able to get the file name and now I would like to get the sheetname from the excel files imported and place in cell "C2"
Sub GetSheets()
'Update Excel Junction.com
Path = "C:\Users\momo\Desktop\Miscellaneous Shipment Packing List\New folder\"
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)
Range("B2").Value = Filename
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

Simply by adding two lines into your loop, you can add the sheetnames:
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
k = 1
For Each Sheet In ActiveWorkbook.Sheets
Cells(2, 2+k).Value = Sheet.Name
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Range("B2").Value = Filename
k = k + 1
Next Sheet
In this example, if your workbooks have several sheets, the sheets will be added in the cells C D E F etc...

Try,
option explicit
Sub GetSheets()
dim wb1 as workbook, sh as worksheet
dim filename as string, path as string
set wb1 = thisworkbook
Path = "C:\Users\momo\Desktop\Miscellaneous Shipment Packing List\New folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
with Workbooks.Open( Filename:=Path & Filename, ReadOnly:=True)
For Each sh In .workSheets
sh.Copy After:=wb1.workSheets(1)
wb1.worksheets(1).cells(rows.count, "B").end(xlup).offset(1,0) = Filename
wb1.worksheets(1).cells(rows.count, "B").end(xlup).offset(0,1) = sh.name
Next sh
.Close savechanges:=false
end with
Filename = Dir()
Loop
End Sub
The rows.count doesn't require a parent because wb1 is either an xls or xlsx and you are opening xls's (unless you are opening more than 65K workbooks).

How to copy only the first sheets of workbooks in a folder into one excel workbook

So I'm using this code, and it is fantastic. If I can get some clues how to tweak it so it only copies the first sheet of the workbooks its pulling from. SIDE NOTE - Please keep in mind that not every workbook's first sheet is titled "Sheet1", some have names inputted.
Sub MergeMultipleWorkbooks()
'Define Variables
Dim Path, FileName As String
'Assign Values to Variables
Path = Assign a Folder which contains excel files for example "C:\Merge\"
FileName = Dir(Path & "*.xlsx")
'Check FileName in the Given Location
Do While FileName <> ""
'Open Excel File
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
'Copy all the sheet to this workbook
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
'Close the ActiveWorkbook
Workbooks(FileName).Close
'Assign a Excel FileName
'Assign Next Excel FileName
FileName = Dir()
Loop
'Display a Message
MsgBox "Files has been copied Successfull", , "MergeMultipleExcelFiles"
End Sub

Sub MergeMultipleWorkbooks()
Dim Path, FileName As String
Path = "C:\Merge\"
FileName = Dir(Path & "*.xlsx")
Do While FileName <> ""
With Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
.Close False
End With
FileName = Dir()
Loop
MsgBox "Files has been copied Successfull", , "MergeMultipleExcelFiles"
End Sub

You have all the parts and pieces here. I just got rid of the For Each loop.
Sub MergeMultipleWorkbooks()
'Define Variables
Dim Path, FileName As String
'Assign Values to Variables
Path = "C:\Merge\"
FileName = Dir(Path & "*.xlsx")
'Check FileName in the Given Location
Do While FileName <> ""
'Open Excel File
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
'Copy the first sheet in file into this workbook
Sheets(1).Copy After:=ThisWorkbook.Sheets(1)
'Close the ActiveWorkbook
Workbooks(FileName).Close
'Assign Next Excel FileName
FileName = Dir()
Loop
'Display a Message
MsgBox "Files has been copied Successfully", , "MergeMultipleExcelFiles"
End Sub

Merge a list of excel files into a new excel book

I need to create a macro that merges a list of excel files in a directory.
The folder contains other files that I don't want to pick. So, I need to specify the list of files (such as, selecting all the files which name contains "02.08.xlsx").
This is my first time using VBA, so please take that into consideration.
I've tried some things, but I think I always get problems regarding the files selection.
Here's what I've tried so far, but not working:
Sub MergeWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim ListFilenames As Variant
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = CurDir()
ListFilenames = Array("*02.08.02.01*.xlsx", "*02.08.13.01*.xlsx")
For i = 1 To 2
Filename = Dir(FolderPath & ListFilenames(i))
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Next i
Application.ScreenUpdating = True
End Sub

The code is wouldb be like this.
Sub MergeWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim ListFilenames As Variant
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = CurDir()
ListFilenames = Array("*02.08.02.01*.xlsx", "*02.08.13.01*.xlsx")
For i = 0 To 1
Filename = Dir(FolderPath & "\" & ListFilenames(i))
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & "\" & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Next i
Application.ScreenUpdating = True
End Sub

Use the AddIn from the link below.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
That will do what you want.

Copy data from multiple workbooks in a folder into one workbook paste special only value

I want to Copy all sheets of multiple workbooks within a folder into another single workbook. I found below code but do not know how to paste special only values to avoid unnecessary formatting.
Sub GetSheets()
Path = "C:\Users\mechee69\Download\"
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

Try the code below, it will PasteSpecial only the Values, if you want you can extend to copy also the Formats.
Option Explicit
Sub GetSheets()
Dim Path As String, Filename As String
Dim WB As Workbook
Dim Sht As Worksheet, ShtDest As Worksheet
Path = "C:\Users\mechee69\Download\"
Filename = Dir(Path & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Filename <> ""
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
For Each Sht In WB.Sheets
Set ShtDest = ThisWorkbook.Sheets.Add(After:=Sheets(1))
Sht.Cells.Copy
ShtDest.Name = Sht.Name '<-- might raise an error in case there are 2 sheets with the same name
ShtDest.Cells.PasteSpecial xlValues
Next Sht
WB.Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Resources