Copy Worksheets from Multiple Workbooks and Merge Into A Master Workbook
This example shows how to accumulate worksheets from a directory full of workbooks and pull all the worksheets into a single workbook. This is valuable if you want to assemble worksheets from numerous workbooks into a single workbook.
Program Code
Option Explicit
Dim strDirectoryLevel1 As String
' ************************************************
'Sample Code For Combining Files for Larry
' ************************************************
Public Sub RASLossRunExample()
Dim strDirectoryPathToWorkbooks As String 'Identify The Directory Path To Input Files
Dim strExcelFileName As String 'Identify The Current Input File
Dim wkbMasterWorkbook As Workbook 'Identify This Application Workbook
Dim wksMasterWorksheet As Worksheet 'Identify The "Application" Directory In The Application
Dim wkbWorkbookToCopy As Workbook 'Roll Through Each Input Workbook And Save the Name
Dim wksWorksheetToCopy As Worksheet 'Identify The Input Worksheet To Copy
Dim strSavedFileNameWithoutPath As String 'Define The Saved File Name Without The Path
Dim strSavedFileNameWithPath As String 'Define The Saved File Name With The Path
' **************************************************
' Put This Master Workbook In A Separate Directory
' Different Than The Target Workbooks
' **************************************************
Application.ScreenUpdating = False
Set wkbMasterWorkbook = ThisWorkbook
Set wksMasterWorksheet = wkbMasterWorkbook.Sheets("Application")
If ActiveWorkbook.Path = "C:\LarryTest" Then
MsgBox ("Please Move the Application To A Different Directory")
Exit Sub
End If
' **************************************************
' If The Directory For Larry's Output Doesn't
' Exist, Then Create The Output Directory
' The Output Directory is: C:\LarryTestOutput\
' **************************************************
Call CreateLarryTestOutputDirectory
' **************************************************
' Copy All Files From C:\LarryTest Into the
' Master Application Workbook
' **************************************************
strDirectoryPathToWorkbooks = "C:\LarryTest\"
strExcelFileName = Dir(strDirectoryPathToWorkbooks, vbNormal)
' **************************************************
' Make Sure At Least One File Exists in the Directory
' **************************************************
If strExcelFileName = "" Then
MsgBox ("No Files Found in C:\LarryTest Directory" & vbCrLf & "Job Cancelled")
Exit Sub
End If
Do Until strExcelFileName = ""
' **************************************************
' Copy Each Of the Sample Workbooks To The Master
' **************************************************
Application.ScreenUpdating = False
Workbooks.Open (strDirectoryPathToWorkbooks & strExcelFileName)
Set wkbWorkbookToCopy = ActiveWorkbook
Set wksWorksheetToCopy = wkbWorkbookToCopy.Sheets(1)
wksWorksheetToCopy.Copy After:=wkbMasterWorkbook.Sheets(wkbMasterWorkbook.Sheets.Count)
wkbWorkbookToCopy.Close SaveChanges:=False
strExcelFileName = Dir
Loop
' **************************************************
' All Files Have Been Processed At This Point
' Create the Updated Saved File Name
' **************************************************
strSavedFileNameWithoutPath = "RASLossRun_" & Format(Date, "mm_dd_yyyy") & "_Time_" & Format(Time, "hh_mm_ss") & ".xlsx"
strSavedFileNameWithPath = strDirectoryLevel1 & strSavedFileNameWithoutPath
' **************************************************
' Activate the Main Application
' **************************************************
wkbMasterWorkbook.Activate
wksMasterWorksheet.Activate
' ****************************************************************************
' Delete the Application Worksheet
' ****************************************************************************
Application.DisplayAlerts = False
wksMasterWorksheet.Delete
Application.DisplayAlerts = True
' **************************************************
' Save The Updated Main Application To
' The Target Directory: C:\LarryTestOutput\
' **************************************************
Application.DisplayAlerts = False
On Error Resume Next
wkbMasterWorkbook.SaveAs Filename:=strSavedFileNameWithPath, FileFormat:=xlOpenXMLWorkbook
On Error GoTo 0
Application.DisplayAlerts = True
MsgBox ("Larry's RAS Loss Run Exported to:" & vbCrLf & _
"Directory: " & strDirectoryLevel1 & vbCrLf & _
"File Name: " & strSavedFileNameWithoutPath)
' **************************************************************
' Quite the Application Without Saving It
' **************************************************************
Application.Quit
Application.ScreenUpdating = True
End Sub
Public Function CreateLarryTestOutputDirectory()
strDirectoryLevel1 = "C:\LarryTestOutput\"
If Not FolderExists(strDirectoryLevel1) Then
MkDir (strDirectoryLevel1)
End If
End Function
Public Function FolderExists(FolderPath As String) As Boolean
' *******************************************************************************************
' * THIS FUNCTION WILL TEST IF A FOLDER EXISTS *
' *******************************************************************************************
On Error GoTo err_In_Locate
' ***********************************************************
' * See If A Folder Exists *
' ***********************************************************
FolderExists = (Len(Dir(FolderPath, vbDirectory)) > 0)
mod_ExitFunction:
Exit Function
' ***************************************************
' * Error Correction Routines *
' ***************************************************
err_In_Locate:
FolderExists = False
Resume mod_ExitFunction
End Function
