当前位置: 动力学知识库 > 问答 > 编程问答 >

Excel VBA: Receiving Method 'Union' of object'_Applcation' failed when macro loops

问题描述:

I keep getting a 'union of object'_application' error when a macro needs to loop to other rows of a filtered range. The macro takes data from a row in a filtered range on workbook1, opens a second workbook2 and places the data in various locations. While the second workbook2 is open, I need to copy/paste some existing data within workbook2 based on a value placed by workbook1. Workbook2 is saved-as and closed and a loop continues to the next row of the filtered range in workbook1 and keeps going until the next cell isEmpty. This macro seems to work fine if my filtered range contains only 1 row and doesn't need to loop. Any more than that and I get the error. I am a noob so I'm guessing my macro is very sloppy. Any help would be appreciated.

Public Sub CreateAllPullTickets()

Application.ScreenUpdating = False

Dim project As String

Dim cablenumber As String

Dim rev As Single

Dim tolocation As String

Dim fromlocation As String

Dim cabletype As String

Dim todwg As String

Dim fromdwg As String

Dim p1pulltemplate As Workbook

Dim r As Range

Dim StartRow As Long

Dim filteredNum As String

Dim cablenumberPT As String

Dim rCell1 As Range

Dim rRng1 As Range

Dim rCell2 As Range

Dim rRng2 As Range

Dim targetRange1 As Range

Dim targetRange2 As Range

On Error GoTo Errorcatch

Set r = ActiveSheet.Range("A3:A80000").Rows.SpecialCells(xlCellTypeVisible)

StartRow = r.Row

filteredNum = Worksheets("MasterCableSchedule").Range("A1")

If ActiveCell.Column <> 1 Or ActiveCell.Row <> StartRow Then

MsgBox ("Please Select First Cable In Column A")

Else

MSG2 = MsgBox("Create " & filteredNum & " Pull Tickets?", vbYesNo)

If MSG2 = vbYes Then

Do Until IsEmpty(ActiveCell)

Worksheets("MasterCableSchedule").Select

project = Range("G1")

cablenumber = Range(ActiveCell.Address)

rev = Range(ActiveCell.Address).Offset(0, 1)

fromlocation = Range(ActiveCell.Address).Offset(0, 2)

tolocation = Range(ActiveCell.Address).Offset(0, 4)

cabletype = Range(ActiveCell.Address).Offset(0, 6)

todwg = Range(ActiveCell.Address).Offset(0, 5)

fromdwg = Range(ActiveCell.Address).Offset(0, 3)

Set p1pulltemplate = Workbooks.Open("C:\TEST\WORKBOOK2.xlsm")

Worksheets("CablePullTicket").Select

With Worksheets("CablePullTicket")

Worksheets("CablePullTicket").Range("E2") = project

Worksheets("CablePullTicket").Range("E4") = cablenumber

Worksheets("CablePullTicket").Range("E5") = rev

Worksheets("CablePullTicket").Range("E6") = tolocation

Worksheets("CablePullTicket").Range("R6") = fromlocation

Worksheets("CablePullTicket").Range("E7") = cabletype

Worksheets("CablePullTicket").Range("E8") = todwg

Worksheets("CablePullTicket").Range("R8") = fromdwg

End With

cablenumberPT = Worksheets("CablePullTicket").Range("E4")

Set targetRange1 = Worksheets("LabeLImport").Cells(1, 2)

Set targetRange2 = Worksheets("LabeLImport").Cells(2, 2)

'IF LOOP NEEDS TO CONTINUE, I BELIEVE THIS IS WHERE IT ERRORS

For Each rCell1 In Worksheets("PointsList").Range("B1:B30000")

If rCell1.Value = cablenumberPT Then

If rRng1 Is Nothing Then

Set rRng1 = rCell1.Offset(0, 6)

Else

Set rRng1 = Application.Union(rRng1, rCell1.Offset(0, 6))

End If

End If

Next

rRng1.Copy

targetRange1.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

Application.CutCopyMode = False

For Each rCell2 In Worksheets("PointsList").Range("B1:B30000")

If rCell2.Value = cablenumberPT Then

If rRng2 Is Nothing Then

Set rRng2 = rCell2.Offset(0, 7)

Else

Set rRng2 = Application.Union(rRng2, rCell2.Offset(0, 7))

End If

End If

Next

rRng2.Copy

targetRange2.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

Application.CutCopyMode = False

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:="C:\TEST\Pull Tickets\" & fromlocation & " - #" & cablenumber & ".xlsm", _

FileFormat:=(52), _

CreateBackup:=False

Application.DisplayAlerts = True

ActiveWorkbook.Close SaveChanges:=False

Do

ActiveCell.Offset(1, 0).Select

Loop While ActiveCell.EntireRow.Hidden = True

Loop

Else

End If

End If

Application.ScreenUpdating = True

Exit Sub

Errorcatch:

MsgBox Err.Description

End Sub

网友答案:

The short answer is that you need to set rRng1 and rRng2 to Nothing before the For Each loop.

Set rRng1 = Nothing
For Each rCell1 in ...

That error means that you're trying to Union two ranges that can't be unioned - most commonly, two cells that are on different worksheets. Your situation is a little more subtle than that. On some level, the cells you're trying to combine are on the same sheet. The problem is that you're opening PointsList each time you loop. So while you always look at the same sheet on PointsList, Excel thinks of it as completely different workbook. Take this example:

Sub test()

    Dim r As Range
    Dim rCell As Range

    Workbooks.Open "C:\Users\dkusleika\Dropbox\Excel\Workbook2.xlsm"

    Set r = Range("a1")

    ActiveWorkbook.Close

    Workbooks.Open "C:\Users\dkusleika\Dropbox\Excel\Workbook2.xlsm"

    Set r = Application.Union(Range("a2"), r)

    ActiveWorkbook.Close

End Sub

All this does is try to union A1 and A2on the active sheet of Workbook2.xlsm. But since I close and reopen the workbook, I get the same error as you. Excel just can't seem to reconcile that they're the same.

In your case, rRng1 still contains the range from the previous loop when it tries to add more ranges from the newly opened PointsList. Not only is that causing the error, I don't think it's what you want. I think you want rRng1 to be different for each iteration of the loop with no carryover from the previous iteration. Setting it Nothing before you loop through the range will do that.

分享给朋友:
您可能感兴趣的文章:
随机阅读: