Free Microsoft Excel 2013 Quick Reference

Merge multiple sheet to one workbook Results

Hi!

I would like to ask if someone can help me with this. this code should merge the first sheet of different workbook in to one. however, i notice that if my workbook has more than one sheet, I would get an error.
Here's the part where the error is ..
it say's says "Object variable or With block variable not set."

Here's the whole code.

'Description: Combines all files in a folder to a master file.
Option Explicit
Public strPath As String
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
'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
Function GetDirectory(Optional Msg) As String
    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 = "Select a folder."
    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 MergeFiles()
    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    ThisWB = ActiveWorkbook.Name
 
    path = GetDirectory("Select a folder containing Excel files you want to merge")
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
            'Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1))
          '  Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count,
ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
 
        Filename = Dir()
    Loop
    Range("A1").Select
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
    MsgBox "Done!"
End Sub
I did not write this code. I got this from a forum. this is exaclty what i need. Except on the error that i stated above. I would appreciate any help. thanks!

VBA to merge multiple Workbooks with multiple sheets into one workbook with multiple sheets, each with a different header row.

Hello

I am using Excel 2007 and want to achieve the following.

I have 75 Workbooks('xlsm) in a directory, with the same 4 worksheets in each.
The names of the 4 worksheets are "Wins","Pitches","Awards","Promo"

Each worksheet has header rows starting at A3 which are unique to that Sheet i.e the headers for "Wins" are different to the headers for "Pitches"etc.
Data always commences at Row A4 regardless of which sheet it is.

Also the data within each sheet contains references to "named Ranges" which need to be retained in the transfer if possible.,

I have tried lots of different VBA's and the RDB Merge Macro, but I come up against any one of the following issues.

a) Sometimes it asks me if I want to replace the Named Range or keep it as it is. (This is very tiresome as I have about 150 named ranges and it asks me over and over for each occurence within the sheets and the workbooks.)

b) I can get pretty close by using RDB Merge, but that restricts me to converting to "values" and does not import the headers or the formats orginally used. Also this has to be repeated for each worksheet separately.

I don't mind if the overall result converts to values as long as the headers and formats are retained for each worksheet.

I would really appreciate any help here.

I need the ability to copy multiple worksheets from one workbook created via Crystal Reports export (ms excel 2003 format) and merge into one worksheet in ms excel 2010. Currently, I am able to use the openfile dialog to open the 2003 workbook, create a new 2010 workbook, and copy the first 2003 worksheet into sheet 1 of the 2010 workbook.

However, when I copy the second 2003 worksheet, I get the famous "The information cannot be copied because the copy area and the paste area are not the same size and shape.

I am using VBA to perform this activity, but I am not able to get past this error. We can have 2003 workbooks that can have anywhere from 3 to 35 worksheets. The first worksheet will contain the header row and then the maximum number of rows allowed on the worksheet. The other worksheets will contain the maximum number of rows on the worksheet with the last worksheet containing less than the maximum. The number of columns can be varied, but I do not have to worry about copying hiddens rows/columns or copying formulas. It is just a straight copy and paste. However, the sheets in the 2003 workbook must be copied in order from sheet 1, sheet 2, sheet 3, etc as this data will usually be in some sort of sorted order.

        With wbkOldWorkBook
        
            .Activate

            For Each wsOldSheet In wbkOldWorkBook.Worksheets
                wsOldSheet.Activate
                
                wbkNewWorkBook.Activate
                wbkNewWorkBook.Sheets(1).Select
                
                wbkOldWorkBook.ActiveSheet.UsedRange.Offset(0).Clear
                    
                    wsOldSheet.UsedRange.Copy
                    
                    wbkNewWorkBook.Activate
                    wbkNewWorkBook.Sheets(1).Select
                    
                        With Range("A65536").End(xlUp).Offset(1, 0)
                            .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                                False, Transpose:=False
                        '.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                        '    False, Transpose:=False
                        End With
                    
            Next
        
        End With
So my question is, what am I doing wrong or what am I missing???

Thanks!!!

Hi,

I am currently doing multiple copy paste tasks from one workbook to another. I would like to make sure that the way I do it is the most efficient.

My source workbook ( where the information from another workbook will be pasted) is subject to changes (the columns might move but will keep the same header). So the first thing I am doing, is creating a module with a sub that search for the source workbook columns headers and the first empty row.


	VB:
	
 
Public sr_name1 As Variant 
Public sr_name2 As Variant 
Public sr_name3 As Variant 
Public sr_first_row As Variant 
 
Public wbA As Workbook, wbB As Workbook 
Public ws1 As Worksheet, ws2 As Worksheet 
 
 
 
Sub define_column_source() 
    Set wbA = ThisWorkbook 
    Set ws1 = wbA.Sheets("Merge") 
    sr_name1 = ws1.Range("a1:cz3").Find(What:="Name 1", LookIn:=xlValues, LookAt:= _ 
    xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
    sr_name2= ws1.Range("a1:cz3").Find(What:="Name 2", LookIn:=xlValues, LookAt:= _ 
    xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
    sr_name3 = ws1.Range("a1:cz3").Find(What:="Name 3", LookIn:=xlValues, LookAt:= _ 
    xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
     
    sr_first_row = ws1.Range("a1:cz3").Find(What:="Name 1", LookIn:=xlValues, LookAt:= _ 
    xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Row + 1 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Then I write another sub in another module where I call the define_column_source sub, open the needed workbook and I copy and paste the information needed to the correct source workbook columns. The other workbook will always have the information starting on the 2nd row.


	VB:
	
 mergefile() 
     
    define_column_source 
     
    Set wbB = Workbooks.Open(ThisWorkbook.Path & "" & "*Workbook1*.xl*", True, True) 
    Set ws2 = wbB.Sheets(1) 
     
    Application.ScreenUpdating = False 
    Application.StatusBar = ("Processing Workbook1...") 
     
    lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row 
     
    col_name1 = ws2.Range("a1:cz3").Find(What:="First Name", LookIn:=xlValues, LookAt:= _ 
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
     
    ws2.Range(Cells(2, col_name1), Cells(lastrow, col_name1)).Copy ws1.Cells(sr_first_row, sr_name1) 
     
    col_name2 = ws2.Range("a1:cz3").Find(What:="Middle Name", LookIn:=xlValues, LookAt:= _ 
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
     
    ws2.Range(Cells(2, col_name2), Cells(lastrow, col_name2)).Copy ws1.Cells(sr_first_row, sr_name2) 
     
    col_name3 = ws2.Range("a1:cz3").Find(What:="Last Name", LookIn:=xlValues, LookAt:= _ 
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _ 
    , SearchFormat:=False).Column 
     
    ws2.Range(Cells(2, col_name3), Cells(lastrow, col_name3)).Copy ws1.Cells(sr_first_row, sr_name3) 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Is there a more efficient way to do this?

Thank you for your help!

Hi all

I am a long-time lurker ... as many of us are and am extremely grateful for the help this place provides. A lot of the time I am able to help myself with the wealth of other posts and guides. This time I am stuck

I have a workbook with 6 sheets of broadly similar data from different external companies. The data is provided roughly weekly but at different times by each company and it always replaces all of the existing data from that company as there are additions/deletions/modifications throughout.Merging the sheets into one sheet with a new column A for CompanyID would be an option ... but that feels like it would be a very tricky data merge/unmerge almost daily and I can't always be around to do it. So a simple sheet replacement seems the best option to me ... perhaps this is an incorrect assumption?

So lets say I have product A, I can get this from any of the companies, and in some cases there may be a few variations so the product will appear multiple times with variation B. A+B is always unique and has unique data to go with it.

I am trying to do a lookup when giving the search terms of A, to ideally give me a list of all the available B variations from each sheet and then when selected the appropriate specifications (this bit I can't quite visualise so for now I am simply giving the variations manually as they are from a set list anyway [but vary from product to product so reduced list would be great])

Right now I use 6 columns with

{=INDEX('CompanyA'!N:N, MATCH(Sheet1!$C$4&Sheet1!$C$6,'CompanyA'!C:C&'CompanyA'!U:U,0))}

returning each row that is relevant. C4 houses my Product ID (A) and C6 the Variation (B)

I could just nest the each of these with IF statements but if Company A supplies the product with variation x as does Company B then I wouldn't get to "see" that I don't think if Company A was first in my IF statement. However it would work in the case of Company A providing variation x and y as I am able to choose that manually which is fine. I could make the company optional as well ... but then I would need to do something to the Array formula above. Somehow concatenate text strings into the formula string to substitute the appropriate Sheet name? To complicate things further the different sheets use different columns for the same data. So
{=INDEX('CompanyB'!O:O, MATCH(Sheet1!$C$4&Sheet1!$C$6,'CompanyB'!C:C&'CompanyB'!U:U,0))}

returns the same charecterstic as the example above. So I would also need to return different Columns. Or I could just name all the ranges, but the problem still remains to change them dynamically based upon the selection of Company.

This is getting messy and I am really not sure it will translate for you all so if anything isn't clear then of course ask me to clarify.

Hello,

I'm trying to merge several sheets (not all) from multiple workbooks into one sheet in a single workbook.

The data I need to copy is placed in sheets Client 1, Client 2, Client 3 in the example file I've attached; I also need to copy cell C3 from summary sheet and paste it at the 1st right sided cell available, along the same range (it will allow me to group the clients from each workbook) .

The example has 3 client sheets, but our workbook has up to 16. The Client sheets always go from sheet 3 to 18, but some users delete the client sheets that have no data, so the amount of sheets to be copied may vary.

Is it possible to skip sheets, using some kind os argument like "if A1=0, go to next sheet"?

Thanks in advance,
Alexandra

Hi,

Here's my problem. I create 6 different reports for 92 departments. To do this, I export the results to Excel worksheets that creates the 6 different reports. Each file name has the number of the report at the end of the file name. What I want to do, is have a macro that searches the directory and creates a workbook for all sheets with the same number at the end of the file name. For example, I have files called F_1.xls, C_1.xls, S_1.xls, Course_1.xls, Student_1.xls, Faculty_1.xls and I want to merge all of the files with the same number _1 into one workbook called NonCompliance_1.xls. I have 92 sets of these 6 files. Any and all help would be appreciated.

Thank you!

Hello everyone,

What i'm trying to do is simple (I thought); but I have yet to find a way to make it work. Ive searched your site, Google, VBA examples - and such. I hope someone here can help, I have some excel knowledge, and some background programming know-how.

I have one workbook, and 2 sheets. On one sheet is a list of Addresses (lets call this Sheet1), and another for Customer Information (Sheet2).

I want to copy the address data from Sheet1 into sheet2 using a keyword in sheet2. I'm looking for the data in Sheet1 (address info) to be merged into one cell, it looks like: Company | Address | City | State | Zip (as columns).

I want to reference the company to always = Address / City / State / Zip when the Company keyword is used in sheet2.

In a nutshell, condense address data from sheet1 into a normal address format, and copy it into sheet2 where the fields correctly match. The address will be entered into a cell next to the Company name.

I'm including a sample file, I hope someone can help or at least point me in a direction I should go with this

Thanks
ae

I've been searching for about an hour now and have yet to find the solution to my problem.

I have 15 workbooks, i.e. Inventory 1, Inventory 2, Inventory 3.

In each of these workbooks there are 5 sheets, Desktops, Laptops, Printers, Monitors, Hubs.

On each sheet, the categories are applicable to the inventory.

Essentially, these 15 workbooks are identical in format, with different data.

I would like to merge all of the workbooks either into one workbook with 5 sheets that has all of the data from all of the workbooks.. or an Access database with all of the data from all of the workbooks. These are workbooks on Sharepoint that are constantly changing so copy/pastespecial does not apply here. I would like to have a spreadsheet that updates from data sources every time you open it so it is always the most current..

I'm versed in C++ but I have no experience with VBA coding at all.. I'd like to get this done today if possible. Any assistance would be appreciated.

Hello All,

This board has helped me a lot in the past, and hopefully can help me again... I'm not very knowlegeable on programming or VB or anything... I've searched and searched on this board but can't find something to do what I'm looking for....

Here's what I need... I have multiple files in a directory, I want to Merge them into one workbook. Now I've found a few scripts to do it, but each one has issues I can't solve... I don't want it too open another workbook and merge, I want it merged into the Master file I'm running the script from. I need it to clear any existing data on the sheet, then merge the data. Each of the individual sheets have headers, so that only needs to be merged once. Plus, if possible, I need it to also copy the formatting and column widths, so the master report looks just like one of the other files, just with ALL the data....

Hopefully someone can figure that out for me... It would be greatly appreciated!!!

Thanks!!

Brian

Hi,

I'm currently using a macro posted by Mr. Tom Urtis on 2/27/06 "Combing/Merging Workbooks in need of help" I would like to change some features to fit my needs a little better.

1. I would like it to paste the values only in the new worksheet.

2. The data I need to copy always starts on coulmn A row 16. I would like it to copy the full row as columns are added each month.

3 Is it posible to have it copy only 5 of the worksheets instead of the full workbook? The naming on the worksheets are all the same... naming convention is as such: custom1, custom2, custom3, custom4 and custom5.

Any help on this would be greatly appreciated.

Thanks claremark

Here is the code originally posted by Mr Tom Urtis

Sub ImportDistricts2()
'Instructional Message Box
MsgBox "Click OK to access the Open dialog." & vbCrLf & _
"Navigate to the folder path that contains" & vbCrLf & _
"the District workbooks you want to import." & vbCrLf & vbCrLf & _
"When you get inside that folder path," & vbCrLf & _
"use your mouse to select one workbook," & vbCrLf & _
"or use the Ctrl button with your mouse" & vbCrLf & _
"to select as many District workbooks" & vbCrLf & _
"as you want from that same folder path." & vbCrLf & vbCrLf & _
"There is a limit of one path per macro run," & vbCrLf & _
"but as many workbooks per path as you want." & vbCrLf & vbCrLf & _
"Please click OK to get started.", 64, "Instructions..."
'Variable declarations
Dim Tlr As Long, Alr As Long, u As String, v As String, w As Worksheet, x As Integer, y As Integer, z As Variant
z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
'Prepare Excel
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Open loop for action to be taken on all selected workbooks.
On Error Resume Next
For x = 1 To UBound(z)
'Error handler within code if Cancel is clicked in Open dialog.
If Err.Number = 13 Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You did not select any workbooks." & vbCrLf & _
"Click OK to exit this macro.", 48, "Import action cancelled."
On Error GoTo 0
Err.Clear
Exit Sub
End If
'Open the workbook(s) that were selected.
Workbooks.Open (z(x))
'Open loop to act on every sheet.
For Each w In ActiveWorkbook.Worksheets
'Identify sheet name
v = w.Name
'Determine if the sheet name in the District workbook also exists in the Main workbook.
'If not, create one in the Main workbook. If so, disregard and move on.
Err.Clear
On Error Resume Next
u = ThisWorkbook.Worksheets(v).Name
If Err.Number 0 Then
With ThisWorkbook
.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = v
End With
End If
On Error GoTo 0
Err.Clear
'At this point we know there is a sheet name in the Main workbook
'for every sheet name in the District workbook, which will remain unique, not duplicated.
'Determine the next available row in the Main workbook for this particular sheet in the District workbook.
'If structures are to guard against run time error if sheet(s) is / are blank.
If Application.CountA(w.Columns(1)) = 1 Then
Alr = 2
Else
Alr = w.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
If Application.CountA(ThisWorkbook.Worksheets(v).Cells) 0 Then
Tlr = ThisWorkbook.Worksheets(v).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
Tlr = 1
End If
'Copy the rows from the District sheet to the Main workbook's sheet whose name is the same.
w.Rows("2:" & Alr).Copy ThisWorkbook.Worksheets(v).Cells(Tlr, 1)
'Continue and terminate the loop for all worksheets in the District workbook.
Next w
'Close the District workbook without saving it.
ActiveWorkbook.Close False
'Continue and terminate the loop for the selected District workbooks.
Next x
'Restore Excel.
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Message box to inform user the job is complete.
MsgBox "The import is complete.", 64, "Done !!"
End Sub

Hello everyone

I have a macro (see code below) that helps me combine multiple sheets from different workbooks into one.

It work fantastically well but i need to make a change to it so that i can use it in my new format.

This macro is set to take each file considering that the first row is the header however my file now an header with 3 rows which mean the data only start at row 4.

Additionally please note that
- row 1 is blank
- row 2 has merge cells (sub column header)
- row 3 has for each column a header
- row onward my data

I have tried to update the code but I keep getting an error which I cannot understand

Would someone know how to update my code so that it works on my new configuration? I need to ensure that the consolidated file takes the first 3 rows as header and then consolidate the data from all the files
(all files have the same header / data structure

Thx a lot

Here is the original code

Sub CombineWorksheets()
Dim strFileName As String
Dim strMyFileName As String
Dim strWorkbookPassword As String
Dim strWorksheetPassword As String
Dim strWorksheetLeaveAlone As String
Dim intHeader As Integer
Dim strWorkbookDirectory As String
Dim intPasteFormats As Integer
Dim intRow As Integer
Dim intRow2 As Integer
Dim wkb As Workbook
Dim wks As Worksheet
'Define passwords and directory
strWorkbookDirectory = InputBox("Please enter the full path of the directory that the files you want to combine are currently sitting. Note that this directory should only contain the files you want to combine, and each file should be in the same order of columns and same format.", "Directory")
strWorkbookPassword = InputBox("What is the password to open each file? (Leave blank if none)", "File Password")
strWorksheetPassword = InputBox("What is the password to open each file? (Leave blank if none)", "Sheet Password")
intPasteFormats = MsgBox("Do you want to include all the formatting?", vbYesNo, "Formats")
intHeader = 0
' Define which sheet to leave alone on each file
strWorksheetLeaveAlone = "Rates"
'Stop screen showing everything - makes it faster
Application.ScreenUpdating = False
'set strMyFileName as the name of this spreadsheet (so we can avoid it in the code)
strMyFileName = ActiveWorkbook.Name
strMySheetName = ActiveSheet.Name
'Clear the sheet
Cells.Select
Selection.ClearContents
'Find first spreadsheet in the directory we need to search. The function
'DIR gets the name of the next file in the relevant directory
strFileName = Dir(strWorkbookDirectory & "/*.xls")
'Loop until all files have been checked
Do Until strFileName = ""
If (UCase(Right(strFileName, 3)) = "XLS") And (strFileName strMyFileName) Then

Application.Workbooks.Open (strWorkbookDirectory & "" & strFileName), , True, , strWorkbookPassword
Workbooks(strFileName).Activate
Workbooks(strFileName).Unprotect strWorksheetPassword
For Each wks In ActiveWorkbook.Worksheets
If wks.Name strWorksheetLeaveAlone Then
If intHeader = 0 Then
Rows("1:1").Copy
Workbooks(strMyFileName).Worksheets(strMySheetName).Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
If intPasteFormats = 6 Then Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
intHeader = 1
End If
wks.Activate
wks.Unprotect strWorksheetPassword
'This is the bit that copies the correct rows. I have assumed that
'the data starts on row 2 and that all the cells in column A have
'something in them. If they don't the ctrl down arrow won't go right to
'the bottom.
Range("A1").Select
Selection.End(xlDown).Select
intRow = ActiveCell.Row
Rows("2:" & intRow).Copy

'This finds the bottom of the sheet and pastes the data into
'the row below
Workbooks(strMyFileName).Activate
intRow = ActiveSheet.UsedRange.Rows.Count
If intRow = 0 Then
Range("A1").Select
Else
Range("A" & intRow + 1).Select
End If
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
If intPasteFormats = 6 Then Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'This empties the clipboard. If you don't do this, when you try to close
'the spreadsheet you'll keep getting the 'excel has data on the clipboard,
'do you want to make it available to other applications?' message
Application.CutCopyMode = False
End If
Next wks
Workbooks(strFileName).Close False
End If
'move onto the next file in the directory (which may not be an xls, hence the check above)
strFileName = Dir()
Loop
'put screen updating back on. This will be the first time you see anything actually happening
Application.ScreenUpdating = True
End Sub

Hi Everyone,

I'm a new poster here.
A google search led me to a closed thread that contained exactly what I need posted by Mr Tom Urtis on Feb 27th, 2006, 07:49 PM in the thread "Combining/Merging Workbooks in need of help!!!!!!!"

It contains what I need but I just wanted one more wrinkle
Is there a way to add a Column to specify the workbook name that the data was taken from?

Example:

Data from the child workbooks "Bob" and "Alice" contains this data
Family Age
Mother 40
Father 40

Master workbook data should have
WorkbookName Family Age
Bob Mother 40
Bob Father 40
Alice Mother 40
Alice Father 40

I would greatly appreciate any help on this. Thank you

Below is the original code posted by Mr Tom Urtis
Sub ImportDistricts()
'Instructional Message Box
MsgBox "Click OK to access the Open dialog." & vbCrLf & _
"Navigate to the folder path that contains" & vbCrLf & _
"the District workbooks you want to import." & vbCrLf & vbCrLf & _
"When you get inside that folder path," & vbCrLf & _
"use your mouse to select one workbook," & vbCrLf & _
"or use the Ctrl button with your mouse" & vbCrLf & _
"to select as many District workbooks" & vbCrLf & _
"as you want from that same folder path." & vbCrLf & vbCrLf & _
"There is a limit of one path per macro run," & vbCrLf & _
"but as many workbooks per path as you want." & vbCrLf & vbCrLf & _
"Please click OK to get started.", 64, "Instructions..."
'Variable declarations
Dim Tlr As Long, Alr As Long, u As String, v As String, w As Worksheet, x As Integer, y As Integer, z As Variant
z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
'Prepare Excel
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Open loop for action to be taken on all selected workbooks.
On Error Resume Next
For x = 1 To UBound(z)
'Error handler within code if Cancel is clicked in Open dialog.
If Err.Number = 13 Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You did not select any workbooks." & vbCrLf & _
"Click OK to exit this macro.", 48, "Import action cancelled."
On Error GoTo 0
Err.Clear
Exit Sub
End If
'Open the workbook(s) that were selected.
Workbooks.Open (z(x))
'Open loop to act on every sheet.
For Each w In ActiveWorkbook.Worksheets
'Identify sheet name
v = w.Name
'Determine if the sheet name in the District workbook also exists in the Main workbook.
'If not, create one in the Main workbook. If so, disregard and move on.
Err.Clear
On Error Resume Next
u = ThisWorkbook.Worksheets(v).Name
If Err.Number 0 Then
With ThisWorkbook
.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = v
End With
End If
On Error GoTo 0
Err.Clear
'At this point we know there is a sheet name in the Main workbook
'for every sheet name in the District workbook, which will remain unique, not duplicated.
'Determine the next available row in the Main workbook for this particular sheet in the District workbook.
'If structures are to guard against run time error if sheet(s) is / are blank.
If Application.CountA(w.Cells) 0 Then
On Error Resume Next
Alr = w.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
Else
Alr = 1
End If
If Application.CountA(ThisWorkbook.Worksheets(v).Cells) 0 Then
Tlr = ThisWorkbook.Worksheets(v).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
Tlr = 1
End If
'Copy the rows from the District sheet to the Main workbook's sheet whose name is the same.
w.Rows("1:" & Alr).Copy ThisWorkbook.Worksheets(v).Cells(Tlr, 1)
'Continue and terminate the loop for all worksheets in the District workbook.
Next w
'Close the District workbook without saving it.
ActiveWorkbook.Close False
'Continue and terminate the loop for the selected District workbooks.
Next x
'Restore Excel.
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Message box to inform user the job is complete.
MsgBox "The import is complete.", 64, "Done !!"
End Sub

Hi I have exhausted all of my contacts and have come up with bits of code from here and there and all haven't worked for me.

I have 50 spreadsheets on the network that need to be merged to 3 individual spreadsheets.

I need code that will merge the sheets into the same sheet I am inserting the code into, with the date and time as the sheet name.

I have found the code below, however, it fails after the first line, so all I get is the first line of each spreadsheet.

One of my worries is that one column in particular is a descriptive field that may contain too many chars, is there a way that we can say, if text is too long, leave blank, as the cell data is not relevant for the report I am doing.

This is the Code that I have inserted into 'This Workbook'

Sub GetData_RCM()
'Copy cells from folder and subfolder(s)
Dim SubFolders As Boolean
Dim Fso_Obj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
Dim RootPath As String, FileExt As String
Dim MyFiles() As String, Fnum As Long
Dim sh As Worksheet, destrange As Range
Dim rnum As Long

'Loop through all files in the Root folder
RootPath = "C:try"

'Loop through the subfolders True or False
SubFolders = False

'Loop through files with this extension
FileExt = ".xls"

'Add a slash at the end if the user forget it
If Right(RootPath, 1) "" Then
RootPath = RootPath & ""
End If

Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
If Not Fso_Obj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If

Set RootFolder = Fso_Obj.GetFolder(RootPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
Fnum = 0

'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If Right(file.Name, 4) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If SubFolders Then
For Each SubFolderInRoot In RootFolder.SubFolders
For Each file In SubFolderInRoot.Files
If Right(file.Name, 4) = FileExt Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolderInRoot & "" & file.Name
End If
Next file
Next SubFolderInRoot
End If

' Now we can loop through the files in the array MyFiles to get the cell values
'******************************************************************

'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = MyFiles(Fnum)

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyFiles(Fnum), "RCM", "A7:DZ7", destrange, False, False

Next
End If
End Sub

... and this is the Module

Option Explicit

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' Changed on June-11-2006
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

If Header = False Then
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If

szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A7"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function
To anyone that can help me, thanks in advance, as this will take me out of a whole lot of wasted time and effort.

makkerc

I have about 30 different workbooks that we update monthly for financial
closing. We want to create one workbook that combines certain sheets from
each of those 30 books, change their tab names and send to the executive team
for monthly reporting. We have figured out that we can run a macro to do
that but it keeps getting hung up at the prompts for updating linked
workbooks and like named tabs. Any suggestions?

Hi

I have a shared workbook which has data added to two separate sheets by
two separate users. I need to combine this data into one summary sheet.
Each day, each user will enter a variable amount of records for the
day, and I then need to merge these two day's worth of data into one
sheet.

All the functions I can find seem to actually match and merge the data
together, wheras I want to keep all records and data, but just combine,
say, 25 records from sheet1 and 32 records from sheet2 to 57 records on
sheet3.

Any suggestions?
Thanks
Pete

Hi.
I have hundreds of woorkbooks(with same headers) that i would like to merge to one sheet with all the data...
The problem is that each workbook has 2 sheets(one with the data and one with an explanation for understanding the sheets data).

I want it to skip the explanation sheet and copy only the 2'nd one...

I'd be more than happy for suggestions...

Thanks a lot...

While researching merging multiple worksheets I came across the following macro authored by Jerry Beaucaire:

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)
'Summary:    Open all Excel files in a specific folder and merge data
'            into one master sheet (stacked)
'            Moves imported files into another folder
Dim fName As String, fPath As String, fPathDone As String, OldDir As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wbkNew As Workbook

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
   
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Master").Activate   'sheet report is built into
   
    If MsgBox("Import new data to this report?", vbYesNo) = vbNo Then Exit Sub
   
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        Cells.Clear
        NR = 1
    Else
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    End If

'Path and filename (edit this section to suit)
    fPath = "C:2010"                  'remember final  in this string
    fPathDone = fPath & "Imported"     'remember final  in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    OldDir = CurDir                     'memorizes the users current working path
    ChDir fPath                         'activate the filepath with files to import
    fName = Dir("*.xls")                'listing of desired files, edit filter as desired

'Import a sheet from found file
    Do While Len(fName) > 0
        If fName <> wbkNew.Name Then     'make sure this file isn't accidentally reopened
        'Open file
            Set wbData = Workbooks.Open(fName)

        'This is the section to customize, replace with your own action code as needed
        'Find last row and copy data
            LR = Range("A" & Rows.Count).End(xlUp).Row
            Range("A1:A" & LR).EntireRow.Copy _
                wbkNew.Sheets("Master").Range("A" & NR)

        'close file
            wbData.Close False
        'Next row
            NR = Range("A" & Rows.Count).End(xlUp).Row + 1
        'move file to IMPORTED folder
            Name fPath & fName As fPathDone & fName
        'ready next filename
            fName = Dir
        End If
    Loop

ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
    ChDir OldDir                             'restores users original working path
End Sub

The above code works fantastic if you are not range specific.

I was then provided with the following tweak to select the ranges I need consolidated:

 'This is the section to customize, replace with your own action code
as needed
        'Find last row and copy data
            LR = Range("A" & Rows.Count).End(xlUp).Row
            Range("A1:A" & LR & ",I1:L" & LR).EntireRow.Copy _
                wbkNew.Sheets("Master").Range("A" & NR)
I am now getting a run time error '1004 "That command cannot be used on multiple selections" and the selection below is highlighted.

            Range("A1:A" & LR & ",I1:L" &
LR).EntireRow.Copy _
                wbkNew.Sheets("Master").Range("A" & NR)
Any suggestions on the fix for this?

Hi there this is a repost of my problem last night since my first post was wrongly done... anyhow here's my problem:

i have this data that have lots of duplicate rows wherein they are the date a certain employee have had his time punch what i want to accomplish is that each date would be having only one row of 2 punch_in and 2 punch out.

here's my workbook: for testing.xlsm

simply put i want my the data in my rawdata sheet to appear like the one i have in sheet1

also i found a working code here though it yields an almost similar result though its not the one that i needed

here's the code:
Sub x()

Dim rInput As Range, oDic As Object, sNames() As String, vInput()
Dim i As Long, nIndex As Long

Set rInput = Range("A1", Range("B65536").End(xlUp))
vInput = rInput.Value
ReDim sNames(1 To UBound(vInput, 1), 1 To 2)
Set oDic = CreateObject("Scripting.Dictionary")

With oDic
    For i = 1 To UBound(vInput, 1)
        If Not .Exists(vInput(i, 1)) Then
            nIndex = nIndex + 1
            sNames(nIndex, 1) = vInput(i, 1)
            sNames(nIndex, 2) = vInput(i, 2)
            .Add vInput(i, 1), nIndex
        ElseIf .Exists(vInput(i, 1)) Then
            sNames(.Item(vInput(i, 1)), 2) = sNames(.Item(vInput(i, 1)), 2) & ", " & vInput(i, 2)
        End If
    Next i
End With

Cells(1, "H").Resize(nIndex, 2) = sNames
' The line below if you want the words in separate columns
' otherwise they are in a single cell, separated by commas
Cells(1, "I").Resize(nIndex).TextToColumns , comma:=True

End Sub
thank you in advance for your help

I found the following code that merges one range from all workbooks in a folder into one new worksheet. As of now, the code is copying the range ("B4:L4") on the third tab of every workbook. Is there a way to modify this code to also copy the ranges ("P4:R4") and ("V4:AA4")? Essential I want to be able to copy multiple ranges instead of just one.

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    ' Change this to the pathfolder location of your files.
    MyPath = "Z:My DocumentsAnalyst RecommendationsTop AnalystsAnalysts ResultsJP MorganTest"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "" Then
        MyPath = MyPath & ""
    End If

    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    ' Add a new workbook with one sheet.
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next

                ' Change this range to fit your own needs.
                With mybook.Worksheets(3)
                    Set sourceRange = .Range("B4:L4")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)

                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub



No luck finding an answer? You could always try Google.