PDA

View Full Version : Consolidate Data from Mutiple Sheets in Summary



Hamond
09-03-2009, 06:15 AM
Hello, I've created the basic structure below for a macro to copy information from mutiple sheets however I'm struggling with the rest and hope someone can help me out!

Basically I want to copy information from mutiple sheet in a workbook and summarise in a sheet called Summary. But there three aspects I am struggling with.


1) The line "Range("IV2").End(xlToLeft).Select" finds the last occurance of information that I want to copy but there are many others separated by blank columns before it it that I also want to extarct. So using the code above A02 finds the the last entry which I want to copy and paste into the summary sheet. But I need to go back to the same sheet to find the next populated column from the last cell copied in the sheet

2) I need to populate the sheet name from which each entry is extracted from. So in my current set up, column A in the summary sheet would contain the actual values and column B would contain the name of the sheet from which value is extracted

3) Don't know how to exlcude the summary sheet from the sheet loop. Only want to take information from the other sheets only!

I've attached a basic example with only three sheets to copy.


Sub LoopThroughSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets

Range("IV2").End(xlToLeft).Select
ActiveCell.Copy

Sheets("Summary").Select

Range("A1000").End(xlUp).Select
Selection.PasteSpecial Paste:=xlPasteValues

Next ws
End Sub


Hope someone can help.

Thanks,

Hamond

Benzadeus
09-03-2009, 08:32 AM
Sub CreateSummary()

Const strSummary As String = "Summary"

Dim cFirst As Long
Dim cLast As Long
Dim cSummaryLast As Long
Dim sht As Worksheet
Dim shtSummary As Worksheet

On Error Resume Next
Application.DisplayAlerts = False
Sheets(strSummary).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set shtSummary = Sheets.Add
shtSummary.Name = strSummary

For Each sht In Sheets
If Not sht.Name = shtSummary.Name Then
With sht
'I'm using row 4 as reference for getting last used column
cLast = .Cells(4, .Columns.Count).End(xlToLeft).Column

'I'm using row 2 as reference for getting first used column
cFirst = .Cells(2, 1).End(xlToRight).Column - 1

'Getting last used column of Summary sheet
'I added 3 because it seens the standard distance between groups
cSummaryLast = shtSummary.Cells(4, shtSummary.Columns.Count).End(xlToLeft).Column + 3

.Range(.Cells(2, cFirst), .Cells(10, cLast)).Copy Destination:=shtSummary.Cells(2, cSummaryLast)

End With
End If
Next sht

Set sht = Nothing
Set shtSummary = Nothing

End Sub

Hamond
09-03-2009, 12:22 PM
Benzadeus,

Thanks for the code.

Whilst I was waiting for a reply, I developed my code further and now have intergrated it with yours. I basically sorted row 2 to get a block of data to copy over.

For someone reason your code did not work on all the sheets and generated an error half way through, I think this was because the copy areas were different in some sheets. But also the code it did not populate the summary sheet with the sheet names and populated the data by rows instead of columns (which I've now fixed by transposing).

Anyway below is the lastest code. It does everything accept populating the summary sheet with the sheet name from which the data is extracted.

Does anyone know how I get the last requirement - populate column B with the sheet names in terms of which sheet the corresponding data has been extracted from?

Thanks,

Hamond


Sub CreateSummary2()

Const strSummary As String = "Summary"
Dim cFirst As Long
Dim cLast As Long
Dim cSummaryLast As Long
Dim sht As Worksheet
Dim shtSummary As Worksheet
Dim lastcol As Integer

On Error Resume Next
Application.DisplayAlerts = False
Sheets(strSummary).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set shtSummary = Sheets.Add
shtSummary.Name = strSummary

For Each sht In Sheets
If Not sht.Name = shtSummary.Name Then
sht.Select
With sht
'Sort each sheet
Rows("2:2").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal

'copy and paste data
lastcol = Range("IV2").End(xlToLeft).Column
.Range(Cells(2, 1), Cells(2, lastcol)).Copy
shtSummary.Range("A6500").End(xlUp).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End With
End If
Next sht
Set sht = Nothing
Set shtSummary = Nothing
End Sub

Benzadeus
09-03-2009, 01:04 PM
Sub CreateSummary()

Const strSummary As String = "Summary"

Dim cLast As Long
Dim cLast2 As Long
Dim sht As Worksheet
Dim shtSummary As Worksheet

On Error Resume Next
Application.DisplayAlerts = False
Sheets(strSummary).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set shtSummary = Sheets.Add
shtSummary.Name = strSummary

For Each sht In Sheets
If Not sht.Name = shtSummary.Name Then
With sht
cLast = shtSummary.Cells(shtSummary.Rows.Count, "A").End(xlUp).Row + 1
.Rows(2).Copy
shtSummary.Cells(cLast, "A").PasteSpecial Transpose:=True
cLast2 = shtSummary.Cells(shtSummary.Rows.Count, "A").End(xlUp).Row
shtSummary.Range(Cells(cLast, "B"), Cells(cLast2, "B")) = sht.Name
End With
End If
Next sht

With shtSummary
.[A1] = "Pair Residual"
.[B1] = "From Worksheet"
.Range("A1:B1").Font.Bold = True
cLast = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A2:A" & cLast).Replace What:="Pair Residual: ", Replacement:=vbNullString
.Columns.AutoFit
End With

Set sht = Nothing
Set shtSummary = Nothing
End Sub