Run-Time Error when trying to Copy a UNION

Question

I am currently writing VBA for excel and getting 1004: "that command cannot be used on multiple selections". My code selects multiple columns in an excel file (non-contiguous) and marries them as a range. Then it copies the range and pastes on another sheet. I have a few Subs that do this for different reports. The first report runs just fine, but when the second report tries to run I get the run-time error. When I select "Debug" it takes me to the range.copy line.

What should I do?

Code below:

Option Explicit
Public wsSheet As Worksheet
Public wbMaster As Workbook
Public wbReport As Workbook
Public rngPartNumber As Range
Public rngPartName As Range
Public rngSupplier As Range
Public rngTPRStatus As Range
Public rngOffTool As Range
Public rngExceptionNotes As Range
Public rngMRD As Range

Sub RunReports()

    Set wbMaster = ActiveWorkbook
    Set wsSheet = wbMaster.Sheets("Part x Part Matrix")
    With wsSheet
        .AutoFilterMode = False
        SetRanges
    End With

    TPRReport
    ExceptionsReport1

    wsSheet.ShowAllData

End Sub

Sub SetRanges()

    wsSheet.Activate
    Set rngPartNumber = Range("C:C")
    Set rngPartName = Range("H:H")
    Set rngSupplier = Range("Q:R")
    Set rngTPRStatus = Range("X:Y")
    Set rngOffTool = Range("Z1", Range("AC1").End(xlDown))
    Set rngExceptionNotes = Range("AH1", Range("AH1").End(xlDown))
    Set rngMRD = Range("AI1", Range("AK1").End(xlDown))
End Sub

Sub TPRReport()

Dim rngTPRResults As Range

    wsSheet.Range("A1").End(xlToRight).AutoFilter Field:=24, Criteria1:="No"
    Set rngTPRResults = Union(rngPartNumber, rngPartName, rngSupplier, rngTPRStatus)
    rngTPRResults.Copy

    Set wbReport = Workbooks.Add
    With wbReport.Worksheets("Sheet1")
        .Range("A1").Select
        .Paste
        .SaveAs Filename:=wbMaster.Path & "\TPR Report" & Format(CStr(Now), "yyyymmdd_hhmm")
    .Close
    End With

End Sub

Sub ExceptionsReport1()
Dim rngExceptions As Range

    wsSheet.Range("A1").End(xlToRight).AutoFilter Field:=38, Criteria1:="X"
    Set rngExceptions = Union(rngPartNumber, rngPartName, rngSupplier, rngTPRStatus, rngOffTool, rngExceptionNotes, rngMRD)
    rngExceptions.Copy

    Set wbReport = Workbooks.Add
    With wbReport.Worksheets("Sheet1")
        .Range("A1").Select
        .Paste
        .SaveAs Filename:=wbMaster.Path & "\Exceptions Report CV" & Format(CStr(Now), "yyyymmdd_hhmm")
    .Close
    End With

End Sub

Answer 1

Building on the answer from Thomas Inzina, the following code will copy the non-contiguous data without copying cells that are not part of the union.

Sub CopyAreas(ByVal Source As Range, _
              ByVal Target As Range, _
              Optional ByVal Inline As Boolean)
    Dim area As Range

    If Inline Then
        For Each area In Source.Areas
            area.Copy Destination:=Target
            Set Target = Target.Offset(area.Rows.Count)
        Next
    Else
        'Find the top-most and left-most cell in the Source
        Dim Topmost As Long, Leftmost As Long
        For Each area In Source.Areas
            If Topmost = 0 Then
                Topmost = area.Row
                Leftmost = area.Column
            Else
                If Topmost > area.Row Then Topmost = area.Row
                If Leftmost > area.Column Then Leftmost = area.Column
            End If
        Next
        'Copy each area to a location offset from the target, such that
        'the topmost cell will be in the row defined by Target and
        'the leftmost cell will be in the column defined by Target
        For Each area In Source.Areas
            area.Copy Destination:=Target.Range(area.Address).Offset(1 - Topmost, 1 - Leftmost)
        Next
    End If
End Sub

Answer 2

Pass the worksheet to your sub procedure and use it to qualify all parent worksheet references.

Sub RunReports()

    Set wbMaster = ActiveWorkbook
    Set wsSheet = wbMaster.Sheets("Part x Part Matrix")
    With wsSheet
        if .AutoFilterMode then .AutoFilterMode = False
        SetRanges .cells(1).parent
    End With

    ...

End Sub

Sub SetRanges(ws as worksheet)
    with ws
        Set rngPartNumber = .Range("C:C")
        Set rngPartName = .Range("H:H")
        Set rngSupplier = .Range("Q:R")
        Set rngTPRStatus = .Range("X:Y")
        Set rngOffTool = .Range("Z1", .Range("AC1").End(xlDown))
        Set rngExceptionNotes = .Range("AH1", .Range("AH1").End(xlDown))
        Set rngMRD = .Range("AI1", .Range("AK1").End(xlDown))
    end with
End Sub