PDA

View Full Version : Solved: Copy data from all the sheets in a workbook into a single sheet



Sreeja
06-18-2007, 06:11 AM
Hi,
I have a workbook with 8 sheets. The headings on all the sheets are the same. I want to copy the data of each sheet and paste it into a new sheet.. in short i want to consolidate the data on all the sheets into one sheet.
Is this possible through VBA ??
If yes.. pls help me with the same.

lucas
06-18-2007, 06:28 AM
See if this works for you....
Option Explicit
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

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

Pam in TX
06-18-2007, 11:11 AM
Lucas,

You rock...... :clap: :clap: We were just discussing this very issue in our office this morning.....

lucas
06-18-2007, 12:33 PM
I yoinked it from someone else...can't remember who..

It is handy though..

Sreeja
06-19-2007, 02:13 AM
Thanks Lucus .... it works::clap: :2jump:

tml
07-04-2007, 01:36 PM
This is great.

How would I skip 1 sheet out of 22 so that it's contents didn't get copied to the master sheet?

mdmackillop
07-04-2007, 01:42 PM
For Each sht In wrk.Worksheets
if sht.name<>"Skip" then
'do things.

tml
07-04-2007, 02:01 PM
When I tried that I got an error compiler error: next without for

mdmackillop
07-04-2007, 02:12 PM
You need to add the corresponding End If. Here's the whole section

'We can start loop
For Each sht In wrk.Worksheets
If sht.Name <> "Skip" Then
'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
End If
Next sht

tml
07-04-2007, 02:34 PM
ok i tried

'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
If sht.Name <> "Labour" Then
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
End If
Next sht

i don't get an error but I have one more sheet after labour and it skips it.

johnske
07-04-2007, 02:57 PM
I yoinked it from someone else...can't remember who..

It is handy though..I think it may be smozgurs (http://vbaexpress.com/kb/getarticle.php?kb_id=151):)

mdmackillop
07-04-2007, 02:58 PM
I gave you the whole section. Why did you do more than substitute Labour for Skip?