Macro to Rollup from mulitple worksheets

[mscurtin67]

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

 

[JoeMo]

You don't need all the selection steps. Try:

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]

That worked perfectly. I will review how you did this so I can learn from this. Awesome job, thank you very much.

 

[JoeMo]

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.