Question

背景：

几年前，我制作了一个电子表格，以生成每天要测试的样本列表。用户（通常是我）复选框以指示要列出的测试样本。然后“保存加载表”按钮使用VBA重新查询数据库连接以获取样本信息，通过一系列复杂的公式填充格式化列表，将值从公式表（“生成器”）复制到另一个表（“LoadSheet”），将该工作表复制到新工作簿，并根据年份和月份将日期作为文件名保存在文件夹中。

它可靠地工作了大约5年，直到几周前我的计算机从带有Office 2013的Windows 7升级到带有Office 2016的Windows 10。

问题：

现在，当我尝试执行代码时，我得到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

这是保存文件的代码。它在指示的行上失败了。

我已经尝试过：

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

它在带有Office 2013的Windows 7上运行良好（并且仍然在同事的Win7 / Excel2013机器上运行），但我在Excel 2016上找不到有关Sheets.Copy方法问题的任何内容，所以我不喜欢不知道其中任何一个是否相关。

有什么想法吗？

编辑：我在同一台计算机（也运行Windows 10和Office 2016）上尝试过它并得到了相同的结果。我不确定安装是否会被破坏，但这不仅仅是巧合。另一台计算机很少被任何人使用，它主要用于运行我编写的SQL Server Express实例和Windows服务，所以我怀疑这会使腐败的可能性降低。

我现在有一个解决方法......我只保存文件，其中包含我用于复制的文件名和路径，然后在每个工作表上执行For Each，删除任何未命名为“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

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

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

我还修改了两个解决方案，以避免您发表评论的潜在错误：

如果它已经存在且当前处于打开状态，则可能会出现错误。

我会就.Copy方法的特定故障与您的IT和/或MS支持人员合作，但这几乎肯定是您的安装问题，并可能在将来导致更糟糕的错误。

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

背景：

问题：

我已经尝试过：

1 个答案: