Master Sheet Macro Help

[marvina2]

Hello, first time posting here.

I've got this master sheet macro that used to work to merge all my tabs into one sheet for printing purposes, but now it gives me a "Run-time error '1004: We can't paste because the Copy are and paste area aren't the same size". It only started happening as I created a new tab/sheet.

Here's the macro;

Sub Merge()
Dim ws As Worksheet
ActiveSheet.UsedRange.Offset(0).Clear
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name And ws.Name <> Sheets("CSI List").Name And ws.Name <> Sheets("List").Name Then
ws.UsedRange.Offset(6).Copy
With Range("A65536").End(xlUp).Offset(1)
.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

End With
End If
Next
End Sub

Any help as to why this is happening would be greatly appreciated.

 

[marvina2]

I do want to merge the data, but I also want the header cells to be merged (in order to understand what division the merged cells fall under). Because your macro is bringing in the header cells of the first sheet perfectly fine, is it not able to duplicate the process for all sheets?

 

[dmt32]

Give this a try:

Sub Merge()
    Dim ws As Worksheet
    Dim Master As Worksheet
    Dim Lastrow As Long
    Dim CopyRng As Range
    
    Set Master = Worksheets("Master")


    With Master
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A2:O" & Lastrow).Clear
    End With


    On Error GoTo myerror
    For Each ws In ActiveWorkbook.Worksheets




        Select Case ws.Name
        Case Master.Name, "CSI List", "List"
            'do nothing
        Case Else


            With ws
                Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
                If Lastrow < 11 Then GoTo nextsh
               Set CopyRng = .Range("A7:O" & Lastrow)
            End With


            With Master
                Lastrow = Master.Cells(Master.Rows.Count, "A").End(xlUp).Row + 1
                CopyRng.Copy
                With .Range("A" & Lastrow)
                    .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                                  False, Transpose:=False
                    .PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                                  False, Transpose:=False




                End With
            End With
        End Select
nextsh:
        Application.CutCopyMode = False
        Set CopyRng = Nothing
    Next ws
myerror:
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave

 

[marvina2]

That is perfect, you're a legend. Thanks mate!