Consolidating selected data from multiple worksheets into new worksheet

[DeonM]

I have a workbook containing 278 worksheets. Each worksheet has exactly the same format (row and column headers and layout). I want to create a new consolidated sheet that consolidates data from selected cells (by cell location) from each worksheet. (Without having to do the manually as it will be a regular task.)

The current worksheet names are unique identifiers and need to be used as the column headers in new sheet.

The consolidated sheet will ideally look like this:

+Name/Worksheet1	+Name/Worksheet2	+Name/Worksheet3	Etc
+Worsheet1!b3	+Worsheet2!b3	+Worsheet3!b3	Etc
+Worsheet1!b4	+Worsheet2!b4	+Worsheet3!b4	Etc
+Worsheet1!b5	+Worsheet2!b5	+Worsheet3!b5	Etc
+Worsheet1!b6	+Worsheet2!b6	+Worsheet3!b6	Etc
+Worsheet1!b7	+Worsheet2!b7	+Worsheet3!b7	Etc
+Worsheet1!b8	+Worsheet2!b8	+Worsheet3!b8	Etc
Etc	Etc	Etc	Etc

<tbody>
</tbody>

I’m using Excel 2010.

 

[Andrew Poulsom]

Welcome to MrExcel.

This may help you:

Merge cells from all or some worksheets into one Master sheet

 

[Oeldere]

I personly think you are better of using the sheetname as an row (instead of a column => (header)), and the data of your 278 sheets in the same format as they are.

I think that will make it much easier to anlyse the data (after the consolidation).

 

[DeonM]

Thank you. I've basically got it to work. From my result so far I would be able to achieve what I need to do (by creating a second lookup table). But there may be a way to just get the macro to do the job.

The current result pastes each value in a new row, each below the other.

Is it possible to paste the range (b5:b45) of sheet1 into the lastrow but instead paste the values from column B to column AP in the same row (i.e. transpose them into columns). Then move to the next row for the next sheet?

The code I'm using now looks like this:

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True


' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"


' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then


' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)


' Specify the range to place the data.
Set CopyRng = sh.Range("b5:b45")


' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If


' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With


' Optional: This statement will copy the sheet ' name in the A column.
DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name


End If
Next


ExitTheSub:


Application.Goto DestSh.Cells(1)


' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[DeonM]

Please ignore my other reply. I found the macro allowing me to merge columns into one summary sheet, which is exactly what I was trying to achieve.

It takes range B1:B45 from each sheet and adds them to the next column.

The only part I can't get to work is to put the name of each sheet in cells A1, B1, C1 etc above the data columns.

The code I'm using is this:

Sub CopyDataAfterLastColumnWithouTitles()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With


' Delete the summary worksheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True


' Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then


' Find the last column with data on the summary
' worksheet.
Last = LastCol(DestSh)


' Fill in the columns that you want to copy.
Set CopyRng = sh.Range("B1:B45")


' Test to see whether there enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Columns.Count > DestSh.Columns.Count Then
MsgBox "There are not enough columns in " & _
"the summary worksheet."
GoTo ExitTheSub
End If


' This statement copies values, formats, and the column width.
CopyRng.Copy
With DestSh.Cells(1, Last + 1)
.PasteSpecial 8 ' Column width
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With


End If
Next


ExitTheSub:


Application.Goto DestSh.Cells(1)


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Andrew Poulsom]

Try changing this:

With DestSh.Cells(1, Last + 1)

to:

DestSh.Cells(1, Last + 1).Value = sh.Name
With DestSh.Cells(2, Last + 1)

 

[DeonM]

Thank you Andrew. Works perfectly.

I could work on it some more for formatting improvements etc but that is easily and quickly done manually.

Is there a book you'd could recommend as an intro to writing this type of macro? It would be good to get a basic understanding of what the code is actually doing, instead of just copying and pasting bits

 

[Andrew Poulsom]

I like John Walkenbach's Power Programming books:

The Spreadsheet Page - Excel Books by John Walkenbach

 

[hiker95]

DeonM,

Is there a book you'd could recommend as an intro to writing this type of macro?

See if something, in the below link, to my most up to date list will help you:

Training / Books / Sites as of 8/30/2014

http://www.mrexcel.com/forum/excel-...anging-columns-rows-advanced.html#post3925232