PDA

View Full Version : Solved: Merging Worksheets into one Master Sheet



canucklady
04-05-2007, 01:03 PM
Hello everyone I am new here, so please have patience with me. Any help would be greatly appreciate. Here is my problem.

I have 10 Worksheets from different branches of our company. All these worksheets have the same headers. Each branch needs to enter data into their worksheet weekly. I then need to combine these worksheets into a master file weekly.

Access would be the easiest way to do it, but supervisor here is against using Access for some reason. Any idea how to do this.

lucas
04-05-2007, 01:16 PM
Check out Joseph's kb entry here (http://vbaexpress.com/kb/getarticle.php?kb_id=829)

lucas
04-05-2007, 01:26 PM
This for combining sheets that are already in one workbook:
Sub Combine_Sheets()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

Application.DisplayAlerts = False
Sheets("Sheet1").Select
Application.DisplayAlerts = True

End Sub


I think Smozgur has a kb entry dealing with this too. Search for combine

canucklady
04-05-2007, 01:58 PM
This works but I need a code that updates the master sheet, the above code creates a new master sheet all the time.

johnske
04-05-2007, 02:13 PM
http://vbaexpress.com/kb/getarticle.php?kb_id=151

lucas
04-05-2007, 02:34 PM
That one creates a new sheet too John.

Try changing this line:

Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
to this:

Set wshTemp = ActiveWorkbook.Worksheets("Master")

Insert a new page called Master and make sure it is active when you run the code.

lucas
04-05-2007, 02:43 PM
I'm kinda with John on this one. seems like if you keep updating an existing sheet that you would be adding to data that is already there......it might be smarter to have it delete the old master and then combine what's left

canucklady
04-05-2007, 03:19 PM
Thanks everyone for your help,

I added this to beginning of code, deleting Master sheet and then creates it, works perfect!!!

Sheets("Master").Select
ActiveWindow.SelectedSheets.Delete

mdmackillop
04-05-2007, 03:40 PM
No need to select; and to avoid warnings
Application.DisplayAlerts = False
Worksheets("Master").Delete
Application.DisplayAlerts = True

lucas
04-05-2007, 05:11 PM
Be sure to mark your thread solved using the thread tools at the top of the page...glad you got it hashed out.

Shane
04-10-2007, 05:55 AM
Hi Guys!

I have a same issue but the only difference is that we have different branches and all there representatives store the data in there worksheets. All worksheets have the same sequence and number of columns. So i have to create a macro that merge all the data from different worksheets in one single master worksheet.

Regards,
Shane

lucas
04-10-2007, 06:40 AM
Do you mean...

all there representatives store the data in their workbooks. All worksheets have the same sequence and number of columns.

johngm
04-11-2007, 04:14 AM
So what did the final code look like? I need the same thing!!

canucklady
04-11-2007, 06:17 AM
Sub MergeWorksheets

Application.DisplayAlerts = False
Worksheets("Master").Delete
Application.DisplayAlerts = True

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

johngm
04-11-2007, 08:04 AM
Thanks for that. I'm having a few problems getting this code to run (because I might be too new to this!) but I wondered, Canucklady did you create the Master using another code and if so which one. Or is this the only code I need to merge from the spreadsheets and update the master. Much appreciated.

lucas
04-11-2007, 08:25 AM
I had trouble running canucklady's code....lot of variables not dimmed and objects not set. Besides it seems to only be working (probably for her specific use) on columns A & B.

Try the code in post #3 for combining worksheets in one workbook....if your looking to combine worksheets from several workbooks look at post #2.

johngm
04-11-2007, 09:01 AM
Thanks Lucas. I would prefer the automatic update feature for the Master sheet from the other sheets. I guess I could just run the macro each time I need an update which would give me the same result.....I think?

lucas
04-11-2007, 09:09 AM
Try this John. Sheet master should already exist...don't worry about formatting it or anything as it will be deleted....Let me know if this is what your looking for.
Sub Combine_Sheets()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
Application.DisplayAlerts = False
Worksheets("Master").Delete
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
ActiveSheet.Name = "Master"
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
' Application.DisplayAlerts = False
' Sheets("Sheet1").Select
Application.DisplayAlerts = True
End Sub

johngm
04-11-2007, 09:46 AM
Hi Lucas - Getting there!! This works!

However this code copies all the column headings for each sheet into the Master as a row. (as all the sheets are the exact same format). I could just delete these rows where they appear on the Master.....unless you know a way around this. Many thanks for your help to date.

lucas
04-11-2007, 09:59 AM
Try this John:
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Application.DisplayAlerts = False
Worksheets("Master").Delete
Application.DisplayAlerts = True
Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be " & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

johngm
04-11-2007, 10:33 AM
Got it Lucas! Perfect!! Many many thanks. I will input this to Access for reporting purposes.:thumb :thumb

lucas
04-11-2007, 10:39 AM
Glad to help John.