Macro to Rollup from mulitple worksheets

mscurtin67

New Member
Joined
Aug 12, 2013
Messages
3
I am not a VBA expert but I was able to find a macro which does most, but not all of what I want. I was looking for a macro which would copy data from mutliple worksheets and into single rollup worksheets. Each of the worksheets are formated the same with the same column headings. My problem is that I need the macro to copy paste values and formatting. Currently it is copying the formuals which then dont work on the rollup.

The current macro code is shown below. Any help with how to modify this to allow it work the same but have copy, paste value and formats is appreciated.

Sub Combine()
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Rollup").Range("A2:AB65536").Clear
On Error GoTo 0
Application.DisplayAlerts = True

Dim ws As Worksheet
' copy headings
Sheets(3).Activate
Range("A5:V5").Select
Selection.Copy Destination:=Sheets(2).Range("A2")
' work through sheets
For Each ws In Worksheets
If ws.Name Like "*ComResp*" Then
ws.Select
Range("A6").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(2, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(2).Range("A65536").End(xlUp)(2)
Sheets(2).Activate
End If
Next
End Sub
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,753
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
You don't need all the selection steps. Try:
Code:
Sub Combine()
Application.DisplayAlerts = False
Worksheets("Rollup").Range("A2:AB65536").Clear

Dim ws As Worksheet, Rws As Long
' copy headings
With Sheets(3)
    .Range("A5:V5").Copy Destination:=Sheets(2).Range("A2")
End With
' work through sheets
For Each ws In Worksheets
If ws.Name Like "*ComResp*" Then
    With ws.Range("A6").CurrentRegion
        Rws = .Rows.Count
        .Offset(2, 0).Resize(Rws - 1).Copy
    End With
    With Sheets(2).Range("A65536").End(xlUp)(2)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
    End With
End If
Next ws
Sheets(2).Activate
End Sub
 

mscurtin67

New Member
Joined
Aug 12, 2013
Messages
3
That worked perfectly. I will review how you did this so I can learn from this. Awesome job, thank you very much.
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,753
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
That worked perfectly. I will review how you did this so I can learn from this. Awesome job, thank you very much.

You are welcome - thanks for your reply.
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,589
Messages
5,765,317
Members
425,272
Latest member
Umba

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top