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

Question

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

Answer 1

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.