That's easy for me to do, adds some work for you. Replace the old code with
that below. You'll still need to make the testCol = "A" change and the
change to the name of the summary worksheet.
There is now an array called addSheets() that you will have to "fill" with
the names of the sheets to be processed. Right now it is set to hold 3 sheet
names:
Dim addSheets(1 To 3) As String
to change the number of sheets to be processed, change the 3 to the total
number of them. After making that change add more
addSheets(#) = "Sheetname"
statements into the code, one for each sheet to be processed.
The code also checks to verify that you've typed the sheet names in
properly, and if it finds one that isn't quite right, it shows you the entry
from the array so you can fix things, and then quits the process. If you
encounter those, look for blanks at the beginning or end of the name as typed
into the sheet's name tab. That's probably the most common error in matching
sheet names.
It also deletes old data from the summary sheet before beginning to rebuild
the sheet. Here's the new code:
Sub BuildSummarySheet()
'JLatham, Excel MVP, 17 APR 2010
'this all depends on there being one
'column that will always have data in it
'on any row that has data change this
'Const value to indicate that column
Const testCol = "A"
Dim summaryWS As Worksheet
Dim anyWS As Worksheet
Dim lastRow As Long
Dim testList As Range
Dim anyTestCell As Range
Dim row2Copy As Range
Dim rowPointer As Long
Dim SLC As Integer
'this array holds the names of the
'sheets that are to be included in
'the processing.
' Change the "To 3" to make it large
' enough to hold all names you need
Dim addSheets(1 To 3) As String
'change this to the summary sheet's name
Set summaryWS = ThisWorkbook.Worksheets("Sheet1")
'put the list of sheets to include
'into the array, modify as required
'note that these sheet names MUST be
'spelled and punctuated just like the
'names on those sheet's tabs.
'Case is not important:
' "Sheet1" = "SHEET1", but
' "Sheet1" <> "Sheet1 "
addSheets(1) = "Sheet2"
addSheets(2) = "SHEET3"
addSheets(3) = "Sheet4"
'this section added to test for valid
'sheet names, and inform you of any
'that can't be found - indicating
'a need to check the name spelling
'in the assignments above
On Error Resume Next
For SLC = LBound(addSheets) To UBound(addSheets)
Set anyWS = ThisWorkbook.Worksheets(addSheets(SLC))
If Err <> 0 Then
Err.Clear
MsgBox "Check the name of sheet:" & vbCrLf _
& "[" & addSheets(SLC) & "]" & vbCrLf _
& "No sheet of that exact name found in this workbook", _
vbOKOnly + vbCritical, "Bad Sheet Name - Aborting"
On Error GoTo 0 ' clear error trapping
GoTo DoHouseCleaning ' exit w/cleanup
End If
Next ' end SLC loop
On Error GoTo 0 ' let system handle errors
'to improve performance
Application.ScreenUpdating = False
'delete all but the first row on the summary sheet
lastRow = summaryWS.Range(testCol & Rows.Count).End(xlUp).Row
If lastRow > 1 Then
summaryWS.Rows("2:" & lastRow).EntireRow.Delete
End If
'begin the actual work
For SLC = LBound(addSheets) To UBound(addSheets)
Set anyWS = ThisWorkbook.Worksheets(addSheets(SLC))
lastRow = anyWS.Range(testCol & Rows.Count).End(xlUp).Row
If lastRow > 1 Then
Set testList = anyWS.Range(testCol & "2:" & _
testCol & lastRow)
For Each anyTestCell In testList
If Not IsEmpty(anyTestCell) Then
Set row2Copy = anyWS.Rows(anyTestCell.Row & _
":" & anyTestCell.Row)
row2Copy.Copy
summaryWS.Range(testCol & Rows.Count).End(xlUp). _
Offset(1, 0).PasteSpecial xlPasteValues
'if you also want formats copied, then
'remove the ' in front of this next line of code
'summaryWS.Range(testCol & Rows.Count).End(xlUp). _
PasteSpecial xlPasteFormats
End If ' end IsEmpty test block
Next ' end anyTestCell loop
End If 'end test for lastRow
Next ' end SLC loop
MsgBox "Summary Sheet Build Completed", vbOKOnly, "Job Done"
DoHouseCleaning:
'do some housekeeping
Set testList = Nothing
Set row2Copy = Nothing
Set summaryWS = Nothing
Set anyWS = Nothing
End Sub
wild turkey no9 said:
Dear JLatham
This is totally awesome. Worked like a charm.
A quick explanation of why I'm doing this - using this idea to workaround
the limitations of multiple consolidation ranges using pivot tables.
Two more favors to ask. Could you add the funcionality to clear all rows on
the summary sheet, except for the first, each time the macro is run.
As one or more of the sheets may contain pivot tables or other data, can I
name the worksheets to include in the row concatenation?
Sorry to trouble you with this but I didn't think this through thoroughly
before asking my original question.
Thanks
Kevin
:
What do you mean by concatenate in this context? Do you want the summary
sheet to contain all of the not-empty rows of data from all of the other
sheets? Or are you somehow wanting some kind of actual summary of the data
on the others?
If you do want all data from all other sheets, then the code below should
help. Be sure that data is not filtered on any sheets to definitely capture
all data. I took the easy way out and assumend that there is at least 1
column that will always have something in it on the sheets on any row that
needs to be copied. Since you said all sheets had same format, I think this
has a good chance of being true?
Sub BuildSummarySheet()
'note that this does not clear existing entries
'from the summary sheet, so multiple runs of
'it will result in replicated entries - you
'should manually clear all previous entries
'before running this code
'this all depends on there being one
'column that will always have data in it
'on any row that has data change this
'Const value to indicate that column
Const testCol = "A"
Dim summaryWS As Worksheet
Dim anyWS As Worksheet
Dim lastRow As Long
Dim testList As Range
Dim anyTestCell As Range
Dim row2Copy As Range
Dim rowPointer As Long
'change this to the summary sheet's name
Set summaryWS = ThisWorkbook.Worksheets("Sheet1")
'to improve performance
Application.ScreenUpdating = False
'begin the actual work
For Each anyWS In ThisWorkbook.Worksheets
If anyWS.Name <> summaryWS.Name Then
lastRow = anyWS.Range(testCol & Rows.Count).End(xlUp).Row
If lastRow > 1 Then
Set testList = anyWS.Range(testCol & "2:" & _
testCol & lastRow)
For Each anyTestCell In testList
If Not IsEmpty(anyTestCell) Then
Set row2Copy = anyWS.Rows(anyTestCell.Row & _
":" & anyTestCell.Row)
row2Copy.Copy
summaryWS.Range(testCol & Rows.Count).End(xlUp). _
Offset(1, 0).PasteSpecial xlPasteValues
'if you also want formats copied, then
'remove the ' in front of this next line of code
'summaryWS.Range(testCol & Rows.Count).End(xlUp). _
PasteSpecial xlPasteFormats
End If ' end IsEmpty test block
Next ' end anyTestCell loop
End If 'end test for lastRow
End If ' end test for sheet name matchup
Next ' end anyWS loop
'do some housekeeping
Set testList = Nothing
Set row2Copy = Nothing
Set summaryWS = Nothing
MsgBox "Summary Sheet Build Completed", vbOKOnly, "Job Done"
End Sub
:
I have data all structured in the same way (same column headings) across
multiple sheets within the same workbook. Is there an easy way to concatenate
all of the data, without any empty rows, into one summary sheet in the
workbook?
Thanks in advance.
Kevin