Ошибка времени выполнения VBA '424' Объект Требуется проблема
Я пытаюсь передать два листа другой подпрограмме в 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
2 ответа
Посмотрите, работаете ли вы с изменениями и комментариями к этому переписать. Я определил рабочий лист и происхождение диапазона ячеек для соответствующей рабочей книги или рабочего листа. Все переменные объявлены явно (без вариантов или объектов, если они не нужны).
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. Поскольку у вас были и старые, и новые, и вам нужно было синхронизировать их имена, это казалось подходящим способом сохранить некоторые строки кода.
Спасибо всем за помощь. Я использовал окно 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 Объект Обязательные ошибки это именно то.