VBA Macro used in the Microsoft Office Excel Application

Excel Copy Multiple Workbooks into One | VBA Macro #11

Share on facebook
Share on twitter
Share on linkedin
This is an Excel Macro to copy separate workbooks into one MASTER workbook. Using your entries in the MASTER spreadsheet’s Details tab this macro will navigate to the folder path and identify the existing Excel workbooks. The Details tab will serve as a guide for this macro seeing if you only want specific workbooks to be combined or all that exist in the folder. If you want only specific workbooks to be copied you can list the workbook names you want them copied into the MASTER. Additionally, you can indicate if you want only the first active tab from each workbook to be copied or all of them. This Excel Macro makes it easy to pull multiple sources of information into one MASTER source on a routine basis. Create a custom button to use this macro across different workbooks impromptu. An InputBox will appear asking for a Folder Path and by default all workbooks and tabs will be copied into the active spreadsheet.
(Click Here to Download the MASTER Excel Spreadsheet utilized in these videos!)


See it in Action!

Watch this video to see this macro in action.

The Code

Here is the code behind this macro.
'Leverage & Lean "Less Clicks, More Results"
Sub CopyMultipleWorkbooksintoMASTER()
' Means variable is in use
Dim AllTabs As String '
Dim AllWorkbooks As String '
Dim Copied As String '
Dim Exist As Boolean '
Dim ExistingWorksheet As Worksheet '
Dim FolderPath As String '
Dim LastColumnLetter As String '
Dim LastColumnNumber As Integer '
Dim LastRow As Integer '
Dim MASTERWB As String '
Dim oFile As Object '
Dim oFolder As Object '
Dim oFSO As Object '
Dim OnlyFirstTab As String '
Dim Rng As Range '
Dim SeparateWB As String '
Dim TabName As String '
Dim WorkbookName As String '
Dim WorkbookNameCounter As Integer '
Dim Worksheet As Worksheet '
Dim WorksheetName As String '

MASTERWB = ActiveWorkbook.Name 'This is the MASTER Workbook everything will be copied too
  
FolderPath = Worksheets(ActiveSheet.Name).Cells(1, 2).Value
If FolderPath = "" Then 'If the FolderPath is blank input it in the box that appears
FolderPath = InputBox("The Folder Path is missing please enter it here.", "Enter Folder Path to Excel Workbooks")
End If

AllWorkbooks = Worksheets(ActiveSheet.Name).Cells(2, 2).Value 'This field determines if all Excel files will be copied
OnlyFirstTab = Worksheets(ActiveSheet.Name).Cells(3, 2).Value 'This field determines if only the first tab will be copied
AllTabs = Worksheets(ActiveSheet.Name).Cells(4, 2).Value 'This field determines if all the tabs will be copied

If AllWorkbooks = "" And OnlyFirstTab = "" And AllTabs = "" Then 'If the Details Tab is missing set Default values
AllWorkbooks = "Yes"
AllTabs = "Yes"
ElseIf OnlyFirstTab = "Yes" And AllTabs = "Yes" Then 'If Yes is indicated to both pick one
MsgBox "You can not indicate Yes to both only first tab and all tabs.  Please say Yes to only one."
Exit Sub
End If

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(FolderPath)

For Each oFile In oFolder.Files 'Loop through every File in FolderPath
If InStr(1, oFile.Type, "Microsoft Excel") <> 0 Then 'If the File Type contains the phrase Microsoft Excel
If AllWorkbooks = "Yes" Then 'Open ALL Excel Workbooks
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Workbooks.Open FolderPath & "\" & oFile.Name, UpdateLinks:=False, ReadOnly:=True
Workbooks(oFile.Name).Activate 'Open Separate Workbook
SeparateWB = ActiveWorkbook.Name
'Copy only First Tab or All Tabs?
If OnlyFirstTab = "Yes" Or AllTabs = "" Then 'Copy and Paste first spreadsheet tab
WorksheetName = ActiveSheet.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row on worksheet
LastColumnNumber = Cells(1, Columns.Count).End(xlToLeft).Column 'Identify Last Column Number in current row
LastColumnLetter = Replace(Cells(1, LastColumnNumber).Address(True, False), "$1", "") 'Identify Last Column Letter in current row
ActiveSheet.Range("A1:" & LastColumnLetter & LastRow).Select 'Set range and copy in seperate Workbook
Selection.Copy
Workbooks(MASTERWB).Activate
Exist = False
For Each ExistingWorksheet In ActiveWorkbook.Worksheets 'Select the appropriate tab in MASTER Workbook
If ExistingWorksheet.Name = WorksheetName Then
Exist = True
End If
Next ExistingWorksheet
If Exist = True Then 'Update existing tab
Sheets(WorksheetName).Select
ElseIf Exist = False Then 'Create new tab
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WorksheetName
Sheets(WorksheetName).Select
End If
Range("A1").PasteSpecial Paste:=xlPasteValues 'Paste into the MASTER Workbook tab
Workbooks(SeparateWB).Close 'Close Separate Workbook
ElseIf AllTabs = "Yes" Then 'Copy and Paste each spreadsheet tab
For Each Worksheet In ActiveWorkbook.Worksheets 'Loop through each spreadsheet tab in Separate Workbook
WorksheetName = Worksheet.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row on worksheet
LastColumnNumber = Cells(1, Columns.Count).End(xlToLeft).Column 'Identify Last Column Number in current row
LastColumnLetter = Replace(Cells(1, LastColumnNumber).Address(True, False), "$1", "") 'Identify Last Column Letter in current row
ActiveSheet.Range("A1:" & LastColumnLetter & LastRow).Select 'Set range and copy in seperate Workbook
Selection.Copy
Workbooks(MASTERWB).Activate
Exist = False
For Each ExistingWorksheet In ActiveWorkbook.Worksheets 'Select the appropriate tab in MASTER Workbook
If ExistingWorksheet.Name = WorksheetName Then
Exist = True
End If
Next ExistingWorksheet
If Exist = True Then 'Update existing tab
Sheets(WorksheetName).Select
ElseIf Exist = False Then 'Create new tab
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WorksheetName
Sheets(WorksheetName).Select
End If
Range("A1").PasteSpecial Paste:=xlPasteValues 'Paste into the MASTER Workbook tab
Next Worksheet
Workbooks(SeparateWB).Close 'Close Separate Workbook
End If
ElseIf AllWorkbooks <> "Yes" Then 'Open SPECIFIC Excel Workbooks
Copied = "No"
WorkbookNameCounter = 5
WorkbookName = Worksheets(ActiveSheet.Name).Cells(WorkbookNameCounter, 2).Value
Do Until WorkbookName = "" Or Copied = "Yes"
If InStr(1, oFile.Name, WorkbookName) <> 0 Then
Copied = "Yes"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Workbooks.Open FolderPath & "\" & oFile.Name, UpdateLinks:=False, ReadOnly:=True
SeparateWB = ActiveWorkbook.Name 'Open Separate Workbook
'Copy only First Tab or All Tabs?
If OnlyFirstTab = "Yes" Or AllTabs = "" Then 'Copy and Paste first spreadsheet tab
WorksheetName = ActiveSheet.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row on worksheet
LastColumnNumber = Cells(1, Columns.Count).End(xlToLeft).Column 'Identify Last Column Number in current row
LastColumnLetter = Replace(Cells(1, LastColumnNumber).Address(True, False), "$1", "") 'Identify Last Column Letter in current row
ActiveSheet.Range("A1:" & LastColumnLetter & LastRow).Select 'Set range and copy in seperate Workbook
Selection.Copy
Workbooks(MASTERWB).Activate
Exist = False
For Each ExistingWorksheet In ActiveWorkbook.Worksheets 'Select the appropriate tab in MASTER Workbook
If ExistingWorksheet.Name = WorksheetName Then
Exist = True
End If
Next ExistingWorksheet
If Exist = True Then 'Update existing tab
Sheets(WorksheetName).Select
ElseIf Exist = False Then 'Create new tab
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WorksheetName
Sheets(WorksheetName).Select
End If
Range("A1").PasteSpecial Paste:=xlPasteValues 'Paste into the MASTER Workbook tab
Workbooks(SeparateWB).Close 'Close Separate Workbook
ElseIf AllTabs = "Yes" Then 'Copy and Paste each spreadsheet tab
For Each Worksheet In ActiveWorkbook.Worksheets 'Loop through each spreadsheet tab in Separate Workbook
WorksheetName = Worksheet.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row on worksheet
LastColumnNumber = Cells(1, Columns.Count).End(xlToLeft).Column 'Identify Last Column Number in current row
LastColumnLetter = Replace(Cells(1, LastColumnNumber).Address(True, False), "$1", "") 'Identify Last Column Letter in current row
ActiveSheet.Range("A1:" & LastColumnLetter & LastRow).Select 'Set range and copy in seperate Workbook
Selection.Copy
Workbooks(MASTERWB).Activate
Exist = False
For Each ExistingWorksheet In ActiveWorkbook.Worksheets 'Select the appropriate tab in MASTER Workbook
If ExistingWorksheet.Name = WorksheetName Then
Exist = True
End If
Next ExistingWorksheet
If Exist = True Then 'Update existing tab
Sheets(WorksheetName).Select
ElseIf Exist = False Then 'Create new tab
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WorksheetName
Sheets(WorksheetName).Select
End If
Range("A1").PasteSpecial Paste:=xlPasteValues 'Paste into the MASTER Workbook tab
Next Worksheet
Workbooks(SeparateWB).Close 'Close Separate Workbook
End If
ElseIf InStr(1, oFile.Name, WorkbookName) = 0 Then 'If current File isn't specific workbook try the next one
WorkbookNameCounter = WorkbookNameCounter + 1
WorkbookName = Worksheets("Details").Cells(WorkbookNameCounter, 2).Value
End If
Loop
End If
End If
Next oFile

Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing

End Sub
'Stay Awesome

Macro Instructions

Watch this video to get started using this macro.

Customization

There are not any code lines to customize for this macro but you can dictate how it behaves based on how you answer the following questions:

Folder Path: Where do you want to search for Excel File Types to copy and paste? (Select if the file type contains the phrase “Microsoft Excel”)

All Workbooks? Do you want to copy and paste ALL the Excel File Types found at this Folder Path?

First Tab? Only copy the first active tab that is select when opening the separate workbooks?

All Tabs? Copy all of the available tabs in each separate workbook.

Specific Workbooks? If you only want to copy specific workbooks in this Folder Path list their names starting in column B6 and continue to add additional names in column B. (Ensure that you enter the names correctly or the copy and paste won’t happen!)

If you create a custom button and run this macro in a spreadsheet that doesn’t contain a “Details” tab an InputBox will appear asking for the path to the folder you want to search.

By default All Workbooks and All Tabs will be copied and pasted into the active spreadsheet.
Subscribe
Notify of
1 Comment
Oldest
Newest Most Voted
Inline Feedbacks
View all comments
trackback

[…] Share on facebook Share on twitter Share on linkedin Have you ever had different Word Documents coming from various sources and need to combine them into one? Say for example a different team member is assigned to work on the Beginning, Middle, and End of a paper. Once each part is complete you have to open each Word Document, select all the content, then copy and navigate back to your original document to paste. Fortunately, there is a better way with VBA! With the Copy Multiple Documents into One macro you can quickly combine all these Word Documents with… Read more »

Search for Excel Macros

Recent Macros

VBA Macro used in the Microsoft Office Outlook Application

Outlook Send Same Email to Different Recipients | VBA Macro #31

To BCC or to not BCC?  That is the question that comes to mind when emailing a variety of different recipients.  This is especially important if you are working with multiple clients.  You can BCC recipients so they can’t click reply all. Recipients won’t see who was emailed but that is actually the problem.  The value is knowing who was emailed so customers know if additional follow-up is needed.  Instead you can CC recipients but once someone hits Reply All the conversation can get out of control.  This can create a bigger problem if the email thread is across multiple parties. Sending separate emails creates more value for the customer but how do you do this efficiently and effectively? You could create new emails do a lot of copying and pasting but this isn’t a sustainable process. Good news is there is always a better way with VBA! Our new Outlook macro makes sending the same email to different recipients so easy!

VBA Macro used in the Microsoft Office Excel Application

Excel Find and Replace across Multiple Word Documents | VBA Macro #30

Say a company rebranded and changed locations.  How would you handle updating all the necessary internal documents with the new company name, address, phone number, and email address? This can be a massive undertaking for any company which is why we created the Excel Find and Replace across Multiple Word Documents macro! This is an Excel macro that will Find and Replace values in Multiple Word Documents. This Excel macro is a great way to maintain Word Documents that are routinely changing information.

VBA Macro used in the Microsoft Office Word Application

Word Create Outlook Email with Selected Text | VBA Macro #29

Have you ever been prompted to send a follow up email while working in Word?  Maybe you are reviewing a meeting agenda or reading a final draft for a new company policy. You can navigate to Outlook create a new email and copy paste the necessary text in.  This takes a bit of time and isn’t very efficient.  Instead try using our Word Macro Create Outlook Email with Selected Text!  This macro will generate an Outlook email directly out of Word pulling in any text you have selected into the Email Body.  This macro is a better way to generate a follow up email helping you get a quicker response. Instead of writing reminders on Post-it notes start using this macro Create Outlook Email with Selected Text today!

First time using VBA?

The Developer Tab is an additional section of the ribbon when activated allows you access to Visual Basic in Applications like Excel, Outlook, Word.
Setup Now
Once the Developer Tab is available you will have the capability to update your security to allow Macros to run in the current application.
Setup Now
A sub of code is a collection of objects and variables. For the code to successfully run a library of references needs to be set.
Setup Now

Looking for more?

Subscribe as an Insider to receive additional rights.

Contact Us

Looking to improve your computer processes?
Leverage & Lean is here to help!

Copyright © 2019 Leverage & Lean – Uptown Style WordPress theme by GoDaddy