我正在尝试将两张表传递到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
答案 0 :(得分：0)
查看您是否完成了对此重写的修改和评论。我已将工作表和单元格范围的父级定义为各自的工作簿或工作表。所有变量都是显式声明的（除非需要，否则没有变体或对象）。
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例程。既然你有旧的和新的并且需要同步他们的名字，这似乎是保存一些代码行的合适方式。
答案 1 :(得分：0)
感谢大家的帮助。我习惯使用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对象所需的错误正是如此。