Multiple Sheet Consolidator into one MasterSheet

[Hotnumbers]

Can someone please Help me with consolidation of multiple sheets into one Master Sheet.

Sheet1: Group 1 Data starts on row 5 with header and additional data above ROW 5 that is not needed in the consolidation I want to copy all the data from row 5 down to MASTER SHeet

Sheet2 : Group 2 data starts on row 5 again it has additional data abve row 5 that is not needed but do not want to recopy the header but copy all the rest fo the data to the last row of the Master Sheet

Sheet3: Group 3 Data starts on row 5 again no header copy all the rest of the rows into master sheet.

I got this code... but it not working properly. I need to to copy starting in row 5 in from the first sheet and start copying from 6 from sheets there after. PLEASE HELP!!!

Sub CopyToMaster()Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, shM As WorksheetDim lRwM As LongSet sh1 = Sheets("Sheet1")Set sh2 = Sheets("Sheet2")Set sh3 = Sheets("Sheet3")Set shM = Sheets("Master")With sh1 .UsedRange.Copy shM.Range("A5")End WithlRwM = shM.UsedRange(Rows.Count).End(xlUp).RowWith sh2 .UsedRange.Offset(1, 0).Resize(.UsedRange.Rows.Count - 1).Copy shM.Cells(lRwM + 1, 1)End WithlRwM = shM.UsedRange(Rows.Count).End(xlUp).RowWith sh3 .UsedRange.Offset(1, 0).Resize(.UsedRange.Rows.Count - 1).Copy shM.Cells(lRwM + 1, 1)End WithEnd Sub

[Trebor76]

For reference, cross posted here (http://www.mrexcel.com/forum/showthread.php?t=608951)

[wakdafak]

i think you can try this
i works with my project


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 = "All File" Then
MsgBox "There is a worksheet called as 'All File'." & vbCrLf & _
"Please remove or rename this worksheet since 'All File' 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 = "All File"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(2)
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


it will copy the header in row 1
and copy all the sheets starting from row 2
i think it is similar with yours :robot

[Hotnumbers]

great... thank you. i will give it a try.

[ivandgerat]

i think you can try this
i works with my project


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 = "All File" Then
MsgBox "There is a worksheet called as 'All File'." & vbCrLf & _
"Please remove or rename this worksheet since 'All File' 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 = "All File"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(2)
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


it will copy the header in row 1
and copy all the sheets starting from row 2
i think it is similar with yours :robot

How if the first column doesn't have data, only column D has the consistent data all the time. What should i change to work?

br,

[hornbyOO]

Hi I've used the above code, and the problem I have is that it appears to use column 1 to decide how many rows to copy however I do not know which column will have the most rows ( and I am unable to sort the longest column to row 1 as I need the columns in a set order) and I can't work out how to get this code to work correctly. :dunno

[omp001]

@hornbyOO

You could try this way:

add the red line bellow
Dim colCount As Integer 'Column count in tables in the worksheets
Dim rowCount As Integer
replace this line
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
by these
With sht.Range("A1").CurrentRegion
rowCount = .Cells(.Cells.Count).Row
End With
Set Rng = sht.Range(sht.Cells(2, 1), sht.Cells(rowCount, colCount))