Question

当宏需要循环到过滤范围的其他行时，我不断收到'object'_application'错误。宏从工作簿1上的过滤范围中的行中获取数据，打开第二个工作簿2并将数据放在不同的位置。当第二个工作簿2打开时，我需要根据workbook1放置的值复制/粘贴工作簿2中的一些现有数据。 Workbook2被保存为as并关闭，循环继续到workbook1中过滤范围的下一行，并一直持续到下一个单元格isEmpty。如果我的过滤范围只包含1行而不需要循环，则此宏似乎可以正常工作。除此之外，我得到了错误。我是一个菜鸟，所以我猜我的宏非常草率。任何帮助将不胜感激。

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

简短的回答是，您需要在For Each循环之前将rRng1和rRng2设置为Nothing。

Set rRng1 = Nothing
For Each rCell1 in ...

该错误意味着您正在尝试Union两个无法联合的范围 - 最常见的是，两个单元格位于不同的工作表上。你的情况比这更微妙。在某种程度上，您尝试合并的单元格位于同一张纸上。问题是每次循环时都会打开PointsList。因此，虽然您总是在PointsList上查看相同的工作表，但Excel会将其视为完全不同的工作簿。举个例子：

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

所有这一切都是尝试在A1的有效工作表上联合A2和Workbook2.xlsm。但是，因为我关闭并重新打开工作簿，我会得到与您相同的错误。 Excel似乎无法调和它们是相同的。

在您的情况下，当rRng1尝试从新打开的PointsList添加更多范围时，Nothing仍包含上一循环的范围。这不仅导致错误，我不认为这是你想要的。我认为你希望rRng1在循环的每次迭代中都是不同的，没有前一次迭代的遗留。在遍历范围之前设置它function drupal_array_get_nested_value(array &$array, array $parents, &$key_exists = NULL) { $ref = &$array; foreach ($parents as $parent) { if (is_array($ref) && array_key_exists($parent, $ref)) { $ref = &$ref[$parent]; } else { $key_exists = FALSE; $null = NULL; return $null; } } $key_exists = TRUE; return $ref; }就可以了。

Excel VBA：当宏循环时，对象'_Applcation'的接收方法'Union'失败

1 个答案: