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

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
18,034
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
 
Upvote 0

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.
 
Upvote 0

Forum statistics

Threads
1,186,808
Messages
5,959,937
Members
438,455
Latest member
Beverly Jarrell

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