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

Смотрите, если вы работаете через изменения и комментарии по этому переписыванию. Я определил листок рабочего листа и ячейки в соответствии со своей рабочей книгой или листом. Все vars явно объявлены (без вариантов).

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 Объект Обязательные ошибки в точности таковы.