VBA运行时错误'；424'；对象要求问题
我试图将两个工作表传递给Excel VBA中的不同子例程，以便对这些工作表进行一些操作。最后，我尝试合并多个工作表中的数据，并删除每个列表中发现的所有重复数据。我将其定义为一个对象：VBA运行时错误'；424'；对象要求问题,vba,excel,dir,Vba,Excel,Dir,我试图将两个工作表传递给Excel VBA中的不同子例程，以便对这些工作表进行一些操作。最后，我尝试合并多个工作表中的数据，并删除每个列表中发现的所有重复数据。我将其定义为一个对象： Set wb1 = Workbooks.Open(Pathname & Filename) Set newWB = Workbooks.Add 然后我只是尝试一个函数： Call ThisSubroutine(wb1.Sheets("Sheetnumber1"), newWB.Sh
Set wb1 = Workbooks.Open(Pathname & Filename)
Set newWB = Workbooks.Add
Call ThisSubroutine(wb1.Sheets("Sheetnumber1"), newWB.Sheets("Sheet2"))
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
Sub MergeDuplicates（ByVal DuplicateFilename作为字符串）”，因为我遇到了“ByRef参数类型不匹配”错误；我不知道为什么Dir函数会出现这种情况，因为它应该传递一个字符串，但这似乎解决了它，至少在编译CheckDuplicates子函数时是这样
“这个有点棘手，但我认为最好的办法是：
'打开原始和副本（查找部分字符串匹配项并打开这两个文件）
Pathname=“\\SRVWIN0791\Daniel\u Armstrong$\TM数据库公司文件\””现在。。。一切都留在我的U盘里
设置wb1=Application.Workbooks.Open（路径名和重复文件名）
Dim Partialname作为字符串
File=Dir（路径名）
Partialname=Left（重复文件名，4）
文件“”时执行此操作
如果StrComp（左（文件，4），Partialname）=0，则
Set wb2=Workbooks.Open（路径名和文件）
如果结束
File=Dir（）
环
'创建新工作簿，创建新工作表并命名
Set newWB=工作簿。添加
对于i=1到6
newWB.Worksheets.Add After:=newWB.Sheets（newWB.Sheets.Count）
接下来我
'将两本工作簿的内容复制到新工作簿中，并将所有内容保留在适当的工作表上
调用CopyToNewTMWB（wb1.Sheets（“一般信息”），newWB.Sheets（“Sheet2”））
调用CopyToNewTMWB（wb1.Sheets（“市场”），newWB.Sheets（“Sheet3”））
调用CopyToNewTMWB（wb1.Sheets（“Chemistries”）、newWB.Sheets（“Sheet4”））
调用CopyToNewTMWB（wb1.Sheets（“处理能力”），newWB.Sheets（“Sheet5”））
调用CopyToNewTMWB（wb1.Sheets（“设备列表”）、newWB.Sheets（“Sheet6”）错误，此处不应使用此功能
请致电CopyToNewTMWB（wb1.Sheets（“分析和质控”）、新WB.Sheets（“Sheet7”））
调用CopyToNewTMWB（wb1.Sheets（“实用程序”），newWB.Sheets（“Sheet8”））
请致电CopyToNewTMWB（wb1.Sheets（“库存化学品”）、newWB.Sheets（“Sheet9”））
newWB.Sheets（“Sheet2”）.Name=“一般信息”
newWB.Sheets（“Sheet3”）.Name=“市场”
新建WB.Sheets（“Sheet4”）.Name=“Chemistries”
newWB.Sheets（“Sheet5”）.Name=“处理能力”
新建WB.Sheets（“Sheet6”）.Name=“设备清单”
新建WB.Sheets（“Sheet7”）.Name=“分析和质量控制”
newWB.Sheets（“Sheet8”）.Name=“实用程序”
新建WB.Sheets（“Sheet9”）.Name=“库存化学品”
调用AddToNewTMWB（wb2.Sheets（“一般信息”），newWB.Sheets（“一般信息”））
调用AddToNewTMWB（wb2.Sheets（“市场”），newWB.Sheets（“市场”））
调用AddToNewTMWB（wb2.Sheets（“Chemistries”）、newWB.Sheets（“Chemistries”））
调用AddToNewTMWB（wb2.Sheets（“处理能力”），newWB.Sheets（“处理能力”））
调用AddToNewTMWB（wb2.Sheets（“设备列表”）、newWB.Sheets（“设备列表”））错误。。。。不应为此目的使用此功能
致电AddToNewTMWB（wb2.Sheets（“分析和质量控制”）、新WB.Sheets（“分析和质量控制”））
调用AddToNewTMWB（wb2.Sheets（“实用程序”），newWB.Sheets（“实用程序”））
致电AddToNewTMWB（wb2.Sheets（“库存化学品”）、newWB.Sheets（“库存化学品”））
'在每个列表上使用excel内置的“删除重复项”功能
表3.范围（“A:A”）。移除的重复列：=1，标题：=xlNo
表3.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
表4.范围（“A:A”）。移除的复制列：=1，标题：=xlNo
表4.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
表4.范围（“D:D”）。移除的重复列：=1，标题：=xlNo
表5.范围（“A:A”）。移除的重复列：=1，标题：=xlNo
表5.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
“这很棘手。。。。不确定如何处理，因为可能会有小的变化；也许根本就不包括它。。。？
Sheet6.范围（“A:Z”）。移除的复制列：=数组（1、2、3、4、5、6、7、8、9、10、11、12、13、14、15、16、17、18、19、20、21、22、23、24）_
标题：=xlYes
表7.范围（“A:A”）。移除的重复列：=1，标题：=xlNo
表7.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
表8.范围（“A:A”）。移除的重复列：=1，标题：=xlNo
表8.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
表9.范围（“A:A”）。移除的重复列：=1，标题：=xlNo
表9.范围（“B:B”）。移除的重复列：=1，标题：=xlNo
对于一般信息和设备清单，这将是一个有点棘手的问题，因为重复的
“设备清单上的所有20个奇数行都需要匹配，一般信息可能是实际更新，因此
'我如何决定更新哪些信息？
'将旧工作簿另存为“公司名称&城市&日期&旧”和“公司名称&城市&日期&副本”！！！！！
wb1.SaveAs文件名：=“\\SRVWIN0791\Daniel\u Armstrong$\TM Duplicate Files\”&DuplicateFilename
wb2.SaveAs文件名：=“\\SRVWIN0791\Daniel_Armstrong$\TM重复文件\”和“合并”格式（日期，“dd-mm-yy”）和文件
'将新创建的工作簿另存为\\SRVWIN0791\Daniel\u Armstrong$\TM数据库公司文件中的“公司名称和城市”\
newWB.SaveAs文件名：=路径名和文件名
'从“TM数据库公司文件”文件夹中删除旧文件
端接头
子CopyToNewTMWB（源工作表作为工作表，目标工作表作为工作表）
Dim numRows为整数，numCols为整数
暗显ActiveRange旧为范围，ActiveRange新为范围
'对单元格进行计数以定义活动范围
numRows=SourceSheet.Cells（Rows.Count，1）.End（xl
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
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