Excel

Combine All Workbooks from One Folder Skipping Blank Sheets

Ease of Use

Easy

Version tested with

2003 

Submitted by:

malik641

Description:

Copies all the worksheets from all the workbooks in one folder into the active workbook. 

Discussion:

This macro was originally created by Jake (DRJ), but I have added some extra functionality. If you use Jake's code while the workbook resides in the same folder, you will get a message indicating that the book is already open and re-opening the workbook will cause a loss of information. Also, Jake's code does not skip blank worksheets. This macro handles both of those items. Also, this version allows you to choose the directory of the excel files to copy, without having to change it from the Visual Basic Editor. 

Code:

instructions for use

			

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

How to use:

  1. Open Excel.
  2. Alt + F11 to open the VBE.
  3. Click Insert --> Module.
  4. Paste the code in the Code Window that opens up.
  5. Close the VBE (Alt + Q or press the X in the top right corner).
 

Test the code:

  1. Click Tools --> Macro --> Macros...
  2. Select CombineFiles and press Run.
  3. *Note that this code will not work on protected sheets.
 

Sample File:

Combine Workbooks.zip 10.72KB 

Approved by mdmackillop


This entry has been viewed 648 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express