Combining multiple sheets onto one

[Steve Barber]

I wrote the following code to combine multiple sheets - it worked fine, now,
however the machine hangs and I have to restart Excel, can anyone show more a
more elegant (less resource hungry) way of achieving my aim?

Many thanks in advance

******** Code Sample **********
sub Build_Summary()
'Now build summary sheet by copying in all the workstream sheets
Sheets("Summary").Select
Range("a1:bb5000").Select
Selection.Clear

Sheets("PMO").Select
Rows("4:2000").Select
Selection.Copy
Sheets("Summary").Select
Range("a1").Select
ActiveSheet.Paste

sheetname = "BC": GoSub copysheet
sheetname = "CSM": GoSub copysheet
sheetname = "OTC": GoSub copysheet
sheetname = "PTP": GoSub copysheet
sheetname = "SCM": GoSub copysheet
sheetname = "MAN": GoSub copysheet
sheetname = "CM": GoSub copysheet
sheetname = "DS": GoSub copysheet
GoTo finished2

copysheet:
Sheets(sheetname).Select
Rows("5:2000").Select
Selection.Copy
Sheets("Summary").Select
Range("A5").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Return
finished2:
End Sub

 

[Dave Peterson]

Your code doesn't look that resource intensive.

But you do have a lot of selects in there. You can copy|Paste directly with
something like:


Option Explicit

Sub Build_Summary2()
'Now build summary sheet by copying in all the workstream sheets

Dim mySheetNames As Variant
Dim SummWks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range
Dim iCtr As Long

mySheetNames = Array("pmo", "bc", "csm", "otc", _
"ptp", "scm", "man", "cm", "ds")

Set SummWks = Sheets("Summary")

With SummWks
.Range("a1:bb5000").Clear
Set DestCell = .Range("a1")
End With

For iCtr = LBound(mySheetNames) To UBound(mySheetNames)
Application.StatusBar = "Processing: " _
& mySheetNames(iCtr) & " at: " & Now

With Worksheets(mySheetNames(iCtr))

If iCtr = LBound(mySheetNames) Then
.Rows(4).Copy _
Destination:=DestCell
Set DestCell = DestCell.Offset(1, 0)
End If

Set RngToCopy _
= .Range("a5", .Cells(.Rows.Count, "A").End(xlUp)).EntireRow

RngToCopy.Copy _
Destination:=DestCell

End With

With SummWks
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

Next iCtr

Application.StatusBar = False

End Sub

But I'm not sure it will help.

(I did change one thing that shouldn't matter much. Instead of always going to
Row 2000, I went to the last row that had something in it in column A.)

 

[John]

Hi Steve,

I'm no expert, but I think its better not to "select" cells and sheets etc.
if you can help it. You should be able to reference cells directly without
selecting.

Anyway, have a go with this. I'm sure there are better ways, but it seems
to work, although you may have to adapt it a little to your needs

Best regards

John

Sub Summarise()

Dim wkSht As Worksheet
Dim sumSht As Worksheet

Set sumSht = ActiveWorkbook.Worksheets("Summary")

sumSht.Cells.Clear

'Run down each column of each sheet except "Summary"
For Each wkSht In Application.ActiveWorkbook.Worksheets
If wkSht.Name <> sumSht.Name Then

'Run across the columns
For c = 1 To 10 Step 1 'Change the 10 to the number of columns
required
iRow = 5 'Change this to your starting row
iCol = c
'Run down rows
Do Until IsEmpty(wkSht.Cells(iRow, iCol))
'Set current summary cell to = summary cell + current
worksheet cell
sumSht.Cells(iRow, iCol).Value = _
sumSht.Cells(iRow, iCol).Value + wkSht.Cells(iRow,
iCol).Value
iRow = iRow + 1
Loop
Next c
Else
End If
Next wkSht

MsgBox "Finished"
End Sub