VBA 运行时错误“424”对象需要问题

Question

我正在尝试将两张工作表传递给 Excel VBA 中的不同子例程，以对这些工作表进行一些操作。最终，我试图合并来自多个工作表的数据并删除每个列表中找到的所有重复数据。我定义为一个对象：

    Set wb1 = Workbooks.Open(Pathname & Filename)
    Set newWB = Workbooks.Add

那我只是尝试一个函数：

    Call ThisSubroutine(wb1.Sheets("Sheetnumber1"), newWB.Sheets("Sheet2"))

我得到一个运行时错误“424”需要对象对话框。我确信这里有一个明显的解决方案，但我忽略了一些东西。子是这样写的：

Sub ThisSubroutine(Sourcefile As Worksheet, Targetfile As Worksheet)

根据要求，我将添加整个代码：

Sub MergeDuplicates(ByVal DuplicateFilename As String) 'used ByVal because I was getting a "ByRef argument type mismatch" error; don't know why this happens with Dir function, as it should be passing a string, but this seems to fix it, at least as far as compiling the CheckDuplicates Sub
    'This one is a bit tricky, but I think the best way to do this is:
    'open the original and the duplicate copy (find partial string matches and open both files)
    Pathname = "\\SRVWIN0791\Daniel_Armstrong$\TM Database Company Files\" 'for now... everything stays in my U drive
    Set wb1 = Application.Workbooks.Open(Pathname & DuplicateFilename)
    Dim Partialname As String
    File = Dir(Pathname)
    Partialname = Left(DuplicateFilename, 4)
    Do While File <> ""
        If StrComp(Left(File, 4), Partialname) = 0 Then
            Set wb2 = Workbooks.Open(Pathname & File)
        End If
        File = Dir()
    Loop

    'Create a new workbook, creates new sheets and name them
    Set newWB = Workbooks.Add
    For i = 1 To 6
        newWB.Worksheets.Add After:=newWB.Sheets(newWB.Sheets.Count)
    Next i

    'copy the contents of both workbooks into the new one keeping everything on the appropriate sheets
    Call CopyToNewTMWB(wb1.Sheets("General Information"), newWB.Sheets("Sheet2"))
    Call CopyToNewTMWB(wb1.Sheets("Markets"), newWB.Sheets("Sheet3"))
    Call CopyToNewTMWB(wb1.Sheets("Chemistries"), newWB.Sheets("Sheet4"))
    Call CopyToNewTMWB(wb1.Sheets("Processing Capabilities"), newWB.Sheets("Sheet5"))
    Call CopyToNewTMWB(wb1.Sheets("Equipment List"), newWB.Sheets("Sheet6")) 'Wrong, should not be using this function here
    Call CopyToNewTMWB(wb1.Sheets("Analytical & QC"), newWB.Sheets("Sheet7"))
    Call CopyToNewTMWB(wb1.Sheets("Utilities"), newWB.Sheets("Sheet8"))
    Call CopyToNewTMWB(wb1.Sheets("Stock Chemicals"), newWB.Sheets("Sheet9"))

    newWB.Sheets("Sheet2").Name = "General Information"
    newWB.Sheets("Sheet3").Name = "Markets"
    newWB.Sheets("Sheet4").Name = "Chemistries"
    newWB.Sheets("Sheet5").Name = "Processing Capabilities"
    newWB.Sheets("Sheet6").Name = "Equipment List"
    newWB.Sheets("Sheet7").Name = "Analytical & QC"
    newWB.Sheets("Sheet8").Name = "Utilities"
    newWB.Sheets("Sheet9").Name = "Stock Chemicals"

    Call AddToNewTMWB(wb2.Sheets("General Information"), newWB.Sheets("General Information"))
    Call AddToNewTMWB(wb2.Sheets("Markets"), newWB.Sheets("Markets"))
    Call AddToNewTMWB(wb2.Sheets("Chemistries"), newWB.Sheets("Chemistries"))
    Call AddToNewTMWB(wb2.Sheets("Processing Capabilities"), newWB.Sheets("Processing Capabilities"))
    Call AddToNewTMWB(wb2.Sheets("Equipment List"), newWB.Sheets("Equipment List")) 'Wrong.... should not be using this function for this purpose
    Call AddToNewTMWB(wb2.Sheets("Analytical & QC"), newWB.Sheets("Analytical & QC"))
    Call AddToNewTMWB(wb2.Sheets("Utilities"), newWB.Sheets("Utilities"))
    Call AddToNewTMWB(wb2.Sheets("Stock Chemicals"), newWB.Sheets("Stock Chemicals"))

    'use excel's built in "remove duplicates" functions on each list
    Sheet3.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet3.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet4.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet4.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet4.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet5.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet5.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
    'This is tricky.... not sure how to handle because there might be minor changes; maybe just don't include it at all...?
    Sheet6.Range("A:Z").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24), _
        Header:=xlYes
    Sheet7.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet7.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet8.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet8.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet9.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Sheet9.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo

    'for general information and the equipment list, this is going to be a bit trickier, because the duplicates
        'on the equipment list require matching for all 20-some-odd rows and the general information may be actual updates so
        'how can I decide what information to update?

    'save the old workbooks as "Company Name & City & Date & Old" and "Company Name & City & Date & Duplicate" in a different folder!!!!!
    wb1.SaveAs filename:="\\SRVWIN0791\Daniel_Armstrong$\TM Duplicate Files\" & DuplicateFilename
    wb2.SaveAs filename:="\\SRVWIN0791\Daniel_Armstrong$\TM Duplicate Files\" & "Merge " & Format(Date, "dd-mm-yy") & " " & File

    'save the newly created workbook as "Company Name & City" in \\SRVWIN0791\Daniel_Armstrong$\TM Database Company Files\
    newWB.SaveAs filename:=Pathname & File

    'Delete the old files from the "TM Database Company Files" folder

End Sub

Sub CopyToNewTMWB(SourceSheet As Worksheet, TargetSheet As Worksheet)

    Dim numRows As Integer, numCols As Integer
    Dim ActiveRangeOld As Range, ActiveRangeNew As Range

    'count cells to define active range
    numRows = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
    numCols = SourceSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Set ActiveRangeOld = SourceSheet.Range(SourceSheet.Cells(1, 1), SourceSheet.Cells(numRows, numCols)) 'set active range equal to appropriate size

    Set ActiveRangeNew = TargetSheet.Range(TargetSheet.Cells(1, 1), TargetSheet.Cells(numRows, numCols)) 'choose range on new worksheet of same size as above
    ActiveRangeNew.Value = ActiveRangeOld.Value 'set the new range values equal to the old ones without having to select any cells

End Sub

Sub AddToNewTMWB(ByVal SourceSheet As Worksheet, ByVal TargetSheet As Worksheet) 'slightly different, just copies the cells to the first unused location

    Dim numRows As Integer, numCols As Integer
    Dim ActiveRangeOld As Range, ActiveRangeNew As Range

    'count cells to define active range
    numRows1 = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
    numRows2 = SourceSheet.Cells(Rows.Count, 2).End(xlUp).Row
    numRowTarget1 = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row
    numRowTarget2 = TargetSheet.Cells(Rows.Count, 2).End(xlUp).Row
    'write duplicates at end of existing list for new worksheet
    Set ActiveRangeOld = SourceSheet.Range(SourceSheet.Cells(1, 1), SourceSheet.Cells(numRows1, 1)) 'set active range equal to appropriate size in first column
    Set ActiveRangeNew = TargetSheet.Range(TargetSheet.Cells(numRowTarget1 + 1, 1), TargetSheet.Cells(numRowTarget1 + numRows1 + 1, 1)) 'choose range on new worksheet of same size as above
    ActiveRangeNew.Value = ActiveRangeOld.Value 'set the new range values equal to the old ones without having to select any cells
    'repeat for 2nd column
    Set ActiveRangeOld = SourceSheet.Range(SourceSheet.Cells(1, 2), SourceSheet.Cells(numRows1, 2)) 'set active range equal to appropriate size in first column
    Set ActiveRangeNew = TargetSheet.Range(TargetSheet.Cells(numRowTarget1 + 1, 2), TargetSheet.Cells(numRowTarget1 + numRows1 + 1, 2)) 'choose range on new worksheet of same size as above
    ActiveRangeNew.Value = ActiveRangeOld.Value 'set the new range values equal to the old ones without having to select any cells

End Sub

Answer 1

看看你是否完成了这次重写的修改和 cmets。我已将工作表和单元格范围父级定义为各自的工作簿或工作表。所有变量都被显式声明（除非需要，否则没有变体或对象）。

Sub MergeDuplicates(DuplicateFilename As String)
    'This one is a bit tricky, but I think the best way to do this is:
    'open the original and the duplicate copy (find partial string matches and open both files)
    Dim fn As String, pn As String, pfn As String, vVALs As Variant
    Dim w As Long, wb1 As Workbook, wb2 As Workbook, newWB As Workbook

    pn = "\\SRVWIN0791\Daniel_Armstrong$\TM Database Company Files\" 'for now... everything stays in my U drive
    Set wb1 = Application.Workbooks.Open(pn & DuplicateFilename)
    fn = Dir(pn)
    pfn = Left(DuplicateFilename, 4)

    Do While CBool(Len(fn))
        If StrComp(Left(fn, Len(pfn)), pfn, vbTextCompare) = 0 Then  'vbTextCompare to remove case sensitive
            Set wb2 = Workbooks.Open(pn & fn)
            Exit Do  '<no sense continuing if you have what you wa
        End If
        fn = Dir()
    Loop

    'Create a new workbook, creates new sheets and name them
    Set newWB = Workbooks.Add
    With newWB
        Do While .Worksheets.Count < 9  'who says every new workbook has three worksheets? Mine has one.
            .Worksheets.Add After:=.Sheets(.Sheets.Count)
        Loop
    End With

    'copy the contents of both workbooks into the new one keeping everything on the appropriate sheets
    Call CopyToNewTMWB(wb1.Sheets("General Information"), newWB.Sheets("Sheet2"))
    Call CopyToNewTMWB(wb1.Sheets("Markets"), newWB.Sheets("Sheet3"))
    Call CopyToNewTMWB(wb1.Sheets("Chemistries"), newWB.Sheets("Sheet4"))
    Call CopyToNewTMWB(wb1.Sheets("Processing Capabilities"), newWB.Sheets("Sheet5"))
    Call CopyToNewTMWB(wb1.Sheets("Equipment List"), newWB.Sheets("Sheet6")) 'Wrong, should not be using this function here
    Call CopyToNewTMWB(wb1.Sheets("Analytical & QC"), newWB.Sheets("Sheet7"))
    Call CopyToNewTMWB(wb1.Sheets("Utilities"), newWB.Sheets("Sheet8"))
    Call CopyToNewTMWB(wb1.Sheets("Stock Chemicals"), newWB.Sheets("Sheet9"))

    'new worksheet renaming moved to CopyToNewTMWB

    'not sure what the parent workbook is... I'm guessing hte newly added one.
    With newWB
    'use excel's built in "remove duplicates" functions on each list
        vVALs = Array("General Information", "Markets", "Chemistries", _
                       "Processing Capabilities", "Analytical & QC", _
                       "Utilities", "Stock Chemicals")
        For w = LBound(vVALs) To UBound(vVALs)
            With .Worksheets(vVALs(w))
                .Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
                .Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
            End With
        Next w
        vVALs = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)
        'leave the brackets surrounding (vVALs) in hte next statement. They are important.
        With Worksheets("Equipment List")  '<-Sheet6
            .Range("A:Z").RemoveDuplicates Columns:=(vVALs), Header:=xlYes
        End With
    End With

    'for general information and the equipment list, this is going to be a bit trickier, because the duplicates
        'on the equipment list require matching for all 20-some-odd rows and the general information may be actual updates so
        'how can I decide what information to update?

    'save the old workbooks as "Company Name & City & Date & Old" and "Company Name & City & Date & Duplicate" in a different folder!!!!!
    wb1.SaveAs Filename:="\\SRVWIN0791\Daniel_Armstrong$\TM Duplicate Files\" & DuplicateFilename

    'Is this the only thing that wb2 is used for? What if it was never found?
    On Error Resume Next
    wb2.SaveAs Filename:="\\SRVWIN0791\Daniel_Armstrong$\TM Duplicate Files\" & "Merge " & Format(Date, "dd-mm-yy") & " " & fn

    'save the newly created workbook as "Company Name & City" in \\SRVWIN0791\Daniel_Armstrong$\TM Database Company Files\
    newWB.SaveAs Filename:=pn & fn

    'Delete the old files from the "TM Database Company Files" folder

End Sub

Sub CopyToNewTMWB(SourceSheet As Worksheet, TargetSheet As Worksheet)

    Dim numRows As Long, numCols As Long
    Dim ActiveRangeOld As Range, ActiveRangeNew As Range

    'count cells to define active range
    With SourceSheet
        numRows = .Cells(Rows.Count, 1).End(xlUp).Row
        numCols = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set ActiveRangeOld = .Range(.Cells(1, 1), .Cells(numRows, numCols)) 'set active range equal to appropriate size
    End With

    With TargetSheet
        Set ActiveRangeNew = .Range(.Cells(1, 1), .Cells(numRows, numCols)) 'choose range on new worksheet of same size as above
        .Name = SourceSheet.Name
    End With

    ActiveRangeNew = ActiveRangeOld.Value 'set the new range values equal to the old ones without having to select any cells

End Sub

请注意，我将新工作表重命名为 CopyToNewTMWB 例程。由于您同时拥有旧的和新的，并且需要同步它们的名称，这似乎是节省一些代码行的合适方法。

Answer 2

感谢大家的帮助。我使用 Locals 窗口检查我的工作簿变量的属性，并意识到 wb1 没有分配。我没有在顶部的 Do 循环中找到原始文件，而是再次找到重复文件并将其重新分配给 wb2。愚蠢的错误，应该早点意识到这一点。我将该循环中的 If 语句更改为：

    Do While File <> ""
        If StrComp(Left(File, 4), Partialname) = 0 And StrComp(File, DuplicateFilename) <> 0 Then 'partially matching filenames will enter this if statement, but not exact matches. Can't have files with the exact same name in the same folder anyway, so this will also pick up "filename" matched with "filename(1)", but will not reassign wb2 when it finds "filename"
            Set wb2 = Workbooks.Open(Pathname & File)
            wb2found = True
            Exit Do
        End If
        File = Dir()
    Loop

道德：424 Object Required 错误正是如此。