升级后，Worksheet类的复制方法失败

背景：

几年前，我做了一个电子表格来生成每天要testing的样本清单。 用户（通常是我）checkbox来指示列出哪些testing的样本。 然后，“保存加载表”button使用VBA重新查询样本信息的数据库连接，通过一系列复杂的公式填充格式化列表，将公式表（“生成器”）中的值复制到另一个表单（“LoadSheet”） ，将该工作表复制到新的工作簿中，并根据年份和月份将date保存为文件夹中的date。

它的工作相当可靠的约5年，直到几个星期前，当我的电脑从Office 2013的Windows 7升级到Windows 10的Office 2016。

问题：

现在，当我尝试执行代码时， Runtime error '1004 ：Worksheet类的复制方法失败”。

 Sub SaveAs() 'Copy to new workbook. Sheets("LoadSheet").Copy '<---This is the line that fails. ' Check directory, create if necessary. If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then MkDir ("G:\Load Sheets\" & Year(Now) & "\") End If MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\") End If 'Save. 'If the worksheet already exists, the user will be asked whether to replace the file or not. 'If it already exists and is currently open, an error could arise. 'Hopefully that won't come up before I have time to think of a way to implement error handling. ActiveWorkbook.SaveAs Filename:= _ "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Range("A1").Select Sheets(1).Select Range("A1").Select ActiveWorkbook.Save Application.CutCopyMode = False ThisWorkbook.Activate Workbooks(Format(Now, "mm-dd-yy") & "x.xlsx").Activate End Sub 

这是保存文件的代码。 它在所示的线上失败。

我已经尝试过了：

• 我试过右键单击工作表选项卡，单击“移动或复制…”，然后尝试在新的工作簿中创build一个副本。 什么都没发生。 没有错误消息，没有新的工作表/书，什么都没有。
• 如果我尝试“移动”而不是“复制”，也会发生同样的事情。
• 如果我尝试右键单击并在同一个工作簿中创build一个副本，我会得到一个新的空白工作表，而不是副本。
• 我试图修复我的Office安装，但没有帮助。
• 我读了一些用户怀疑文件损坏的情况，所以我甚至尝试通过Ctrl + A，C，V一次手动将内容复制到新的工作簿，然后对代码执行相同的操作。 没有效果。
• 我试过Sheets(Worksheets.Count).Select后面跟着ActiveSheet.Copy ，因为表格是书中的最后一个，但是当然不起作用。
• 我读过这可能是因为工作簿需要先保存，所以我在复制之前尝试了ActiveWorkbook.Save 。 还是一样的结果。
• 我试着反编译/重新编译工作表不起作用。

它适用于Windows 7与Office 2013（仍然在同事的Win7 / Excel2013机器上），但我找不到有关Excel 2016中Sheets.Copy方法的问题，所以我不知道如果其中任何一个是相关的。

有任何想法吗？

编辑：我已经在同一台计算机上（也运行Windows 10＆Office 2016）尝试过，并有相同的结果。 我不确定安装会受到多大程度的损坏，但这种感觉不仅仅是巧合。 另一台计算机很less被任何人使用，它主要用于运行一个SQL Server Express实例和一个我写的Windows服务，所以我怀疑这使腐败更不可能。

我现在有一个解决方法…我只保存文件的文件名和path，我将用于副本，然后在每个工作表中删除任何未命名为“LoadSheet”的东西。

 Sub SaveAs() On Error GoTo SaveAs_Err 'Check directory, create if necessary. If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" Then If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" Then MkDir ("G:\Load Sheets\" & Year(Now) & "\") End If MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\") End If ' Turn off alerts. They're annoying. I don't care if it's poor form, I just want to be done with this. I'm not being paid to write code. Application.DisplayAlerts = False 'Save, disregarding consequences. ActiveWorkbook.SaveAs Filename:= _ "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ' Remove extraneous sheets. Dim ws As Worksheet For Each ws In ActiveWorkbook.Sheets If ws.Name <> "LoadSheet" Then ws.Delete Next Application.DisplayAlerts = True Exit Sub SaveAs_Err: Application.DisplayAlerts = True MsgBox ("An error occurred while saving the file.") Debug.Print "Error " & Err.Number & ": " & Err.Description End Sub 

我仍然对解决这个问题的根源感兴趣，所以如果有人有想法，我全是耳朵！ 我可能仍然会尝试卸载/重新安装，但我不希望它改变任何东西。

Answer 1

蛮力修复，请尝试：

 Sub SaveAs() Dim newWB as Workbook, i as Integer, copyRange as Range, fName as String Set newWB = Workbooks.Add While newWB.Worksheets.Count > 1 newWB.Worksheets(newWB.Worksheets.Count).Delete Wend newWB.Worksheets(1).Name = "LoadSheet" ' get a handle on the sheet's usedRange object Set copyRange = ThisWorkbook.Worksheets("LoadSheet").UsedRange ' assign the values to the newWB.Worksheets(1) 'newWB.Worksheets(1).Range(copyRange.Address).Value = copyRange.Value copyRange.Copy Destination:=newWB.Worksheets(1).Range(copyRange.Address) 'Check directory, create if necessary. If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then MkDir ("G:\Load Sheets\" & Year(Now) & "\") End If MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\") End If fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x" If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx" If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm" newWB.SaveAs Filename:= fName, _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Workbooks.Open(fName) End Sub 

或者，使用Worksheets类的SaveAs方法：

 Sub SaveAs() Dim fName as String 'Check directory, create if necessary. If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then MkDir ("G:\Load Sheets\" & Year(Now) & "\") End If MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\") End If fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x" If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx" If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm" ThisWorkbook.Worksheets("LoadSheet").SaveAs Filename:= fName, _ FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWorkbook.Save Application.CutCopyMode = False Workbooks.Open(fName) End Sub 

我也修改了这两个解决scheme，以避免您评论的潜在错误：

如果它已经存在并且正在打开，则可能会出现错误。

我会和您的IT和/或MS支持人员一起讨论.Copy方法的具体失败，但是这几乎肯定是您安装时遇到的一个问题，将来可能会导致更糟的错误。