试图复制UNION时运行时错误

我目前正在为excel编写VBA并获得1004：“该命令不能用于多个select”。 我的代码selectExcel文件（非连续）中的多个列，并将它们作为范围结婚。 然后它将范围和粘贴复制到另一张纸上。 我有几个子公司为不同的报告做这个。 第一个报告运行得很好，但是当第二个报告试图运行时，我得到了运行时错误。 当我select“debugging”时，它把我带到range.copy行。

我该怎么办？

代码如下：

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

将工作表传递给子过程，并使用它来限定所有父工作表引用。

 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 

Answer 2

基于Thomas Inzina 的回答 ，以下代码将复制不连续的数据，而不复制不属于联合的部分的单元格。

 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