Solved: Merging a specific worksheet from multiple workbooks into one

[Beatrix]

Hi All ,

I need to pull data from 50 xls files into 1. Each workbook has same format and data I need to pull is saved in a specific worksheet in each workbook.

I've checked Knowledge Base and found the code below. This one combines multiple workbooks into one by adding worksheets separately.

http://www.vbaexpress.com/forum/showthread.php?t=39604

What I need is merging a specific worksheet from multiple workbooks into one. Master copy of 50 xls files would be cumulative so data from individual copies needs to be merged to end of the list in master worksheet. I was wondering if there is any written code I could use to do this?

your help is appreciated.

Cheers
Yeliz

[Bob Phillips]

[vba]

Public Sub MergeWorkbooks()
Const ROOT_FOLDER As String = "C:\temp\"
Dim wbTarget As Workbook
Dim Filename As String
Dim filenames As Variant
Dim numrows As Long
Dim nextrow As Long

Set wbTarget = Workbooks.Add

Filename = Dir(ROOT_FOLDER & "*.xls*")
ReDim filenames(1 To 1)

nextrow = 1
Do While Filename <> ""

Workbooks.Open Filename
With ActiveWorkbook

With .Worksheets(1)

numrows = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(1).Resize(numrows).Copy wbTarget.Worksheets(1).Cells(nextrow, "A")
nextrow = nextrow + numrows
End With

.Close SaveChanges:=False
End With

Filename = Dir
Loop

'do something with wbTarget
End Sub[/vba]

[Beatrix]

Thanks very much for express response!..

I guess I don't need to define file names for 50 xls. This code would run for all xls files under specified folder, am I right?

Each xls file has more than 1 worksheet however the tabs are named same in each workbook. How can I specify the worksheet I need to merge by using this code? do I need to edit this bit?

With .Worksheets(1)

Sorry I am vba newbie and taking a course early march so it would make better sense after that :o)

[Bob Phillips]

You mean that the data from say worksheets ABC gets appended to worksheets ABC, XYZ to XYZ etc.? Do you have a workbook that they get appended to already or do we create a new one dynamically?

[Beatrix]

hmm I see what you mean..It doesn't need to be dynamic. Let's say each xls file has 3 tabs. called A, B, C. I want to pull the data from worksheet A only from 50 xls files. I guess I need to specify the worksheet as Worksheet(A)..

sorry if this doesn't make sense :o)

[mdmackillop]

Put the name in quotes
[VBA]With .Worksheets("A")[/VBA]

[Beatrix]

thanks very much!!

[Bob Phillips]

So are you sorted now Yeliz?

[Beatrix]

So are you sorted now Yeliz?

I've run the macro and it just created new workbook which is blank :o)

I did copy this below code into master file and edited file address and worksheet name. It didn't work. I don't know what went wrong as it didn't give me an error. It just opened a blank workbook.

[VBA]
Public Sub MergeWorkbooks()
Const ROOT_FOLDER As String = "C:\HPOD\Individual Copies"
Dim wbTarget As Workbook
Dim Filename As String
Dim filenames As Variant
Dim numrows As Long
Dim nextrow As Long

Set wbTarget = Workbooks.Add

Filename = Dir(ROOT_FOLDER & "*.xls*")
ReDim filenames(1 To 1)

nextrow = 1
Do While Filename <> ""

Workbooks.Open Filename
With ActiveWorkbook

With .Worksheets("H - POD")

numrows = .Cells(.Rows.Count, "A").End(xlUp).Row
.Rows(1).Resize(numrows).Copy wbTarget.Worksheets(1).Cells(nextrow, "A")
nextrow = nextrow + numrows
End With

.Close SaveChanges:=False
End With

Filename = Dir
Loop

'do something with wbTarget
End Sub[/VBA]

[mancubus]

change
[VBA]Const ROOT_FOLDER As String = "C:\HPOD\Individual Copies"[/VBA]


to
[VBA]Const ROOT_FOLDER As String = "C:\HPOD\Individual Copies\"[/VBA]

[Beatrix]

when I add \ to folder address then it gives run time error 1004 saying ;

H-POD_S1_v01.t1.xls could not be found. Check the spelling of the file name, and verify that the file location is correct.

I didn't specify any file name in the code as I thought all xls files would be included under the folder. I don't know what's causing this error :|

[mdmackillop]

[VBA]Workbooks.Open ROOT_FOLDER & Filename [/VBA]

[Beatrix]

[vba]Workbooks.Open ROOT_FOLDER & Filename [/vba]

Thanks for your reply. I have 50 xls files to merge so do I need to write all file names in code?

Cheers
Yeliz

[mancubus]

"Filename" is a variable for all file names, which is:

[vba]Filename = Dir(ROOT_FOLDER & "*.xls*")[/vba]

[vba]Do While Filename <> ""
[/vba]
tells excel loop all files in the folder...

so just change the line in your post to the line in MD's post..

[Beatrix]

mancubus thanks very much for your response and for the explanation as well..

I did change the line as
Workbooks.Open ROOT_FOLDER & Filename
now macro is running but because of format issues it didn't work as I expected. It opens a new workbook and pulls data from first file then stops. I guess I need to verify columns as each worksheet has same format and same formula settings then this causing overlap etc..

I attached 3 sample files to explain the problem. 1 xlsm file which is master copy, 2 xls to extract data from.

I appreciate for your patience.

Cheers
Yeliz

"Filename" is a variable for all file names, which is:

[vba]Filename = Dir(ROOT_FOLDER & "*.xls*")[/vba]

[vba]Do While Filename <> ""
[/vba] tells excel loop all files in the folder...

so just change the line in your post to the line in MD's post..

[mancubus]

worksheets are protected.
your tables' topleft cells are not "A1"
blah blah blah

so i recommend you use ron de bruin's code below.

that code will consolidate worksheets "H-POD" of all files that you selected from folder in one worksheet named "Master".

if you like consolidating in a new blank workbook then delete leading ' (single quote) in the following line
[vba] 'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
[/vba]
and add a ' (single quote) in the following lines
[vba] Set BaseWks = Worksheets.Add
BaseWks.Name = "Master"
[/vba]

tested with your files and that's ok.


this bit of the code adds workbooks' names in column A.
[vba]
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(FNum)
End With
[/vba]
you may delete this bit if you don't want file names...

in this case change "B" to "A" in this line:
[vba]
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
[/vba]


(copy the header row manually...)



[vba]
Sub MergeSpecificWorkbooks()
'http://www.rondebruin.nl/copy3.htm

Dim MyPath 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
Dim SaveDriveDir As String
Dim FName As Variant

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

' SaveDriveDir = CurDir
' ChDirNet "C:\Users\Ron\test"

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Set BaseWks = Worksheets.Add
BaseWks.Name = "Master"
rnum = 2

'Loop through all files in the array(myFiles)
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets("H-POD")
.Unprotect
LC = .Cells(.Rows.Count, "C").End(xlUp).Row
Set sourceRange = .Range("B10:M" & LC)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use 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 "Sorry there are not enough rows in the sheet"
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 = FName(FNum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
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 ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

' ChDirNet SaveDriveDir

End Sub
[/vba]

[Beatrix]

Thank you so much mancubus!! This is exactly what I was looking for. It's working perfect..

I'll be more careful next time about table format..

Cheers
Yeliz

[mancubus]

you're wellcome.

but i just copied the code and adopted a few lines of it to your table structure.

[mancubus]

re to pm:

it worked with 15 sample files... three of them contain only headers...

for any updates, just select the new files after running the macro... the code adds new records from to the bottom of "Master" sheet.

keep worksheet H-POD in master.xlsm, from which the code retrieves the headers...

the code checks the existence of records from column C and row 10.

[Beatrix]

It worked with 51 xls. Brilliant! Thanks again for your time, much appreciated.