将一个工作表复制到一个新的工作簿。

Question

我在使用ws.copy时遇到了运行时错误 -> 没有这段代码，程序可以正常工作，但只会创建一个空的工作簿。

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String
filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"

' Create a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add

' Copy the worksheet to the new workbook
ws.Copy 'After:=newWorkbook.Worksheets(1)

' Save the new workbook
newWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
newWorkbook.Close SaveChanges:=False
End Sub

- Zaiga

Answer 1

将工作表复制到新工作簿

• 如果您将 As Worksheet 替换为 As Object，该过程也可用于图表。
• 要引用上次打开的工作簿，可以安全地使用 Workbook(Workbooks.Count)。
• 关闭 Application.DisplayAlerts 以无需确认覆盖。如果不这样做，当文件存在时，系统会要求您保存它。如果选择 No 或 Cancel，则会出现以下错误：
  Run-time error '1004': Method 'SaveAs' of object '_Workbook' failed
• 如果您想要引用工作表所在的工作簿，可以使用 .Parent 属性。然后该过程不仅限于包含此代码的工作簿 (ThisWorkbook)。否则，请将 Sheet.Parent 替换为 ThisWorkbook。
• 如果您使用斜杠 (\) 的代替方式是 Application.PathSeparator，该过程也可用于具有其他操作系统的计算机。
• 对于新工作簿，默认类型为 .xlsx，因此您不需要指定文件扩展名或格式。

Sub SaveSheetAsXlsx(ByVal Sheet As Object)
    ' Copy the sheet to a new single-sheet workbook.
    Sheet.Copy
    ' Reference, save and close the new workbook.
    Dim nwb As Workbook: Set nwb = Workbooks(Workbooks.Count)
    Application.DisplayAlerts = False ' overwrite without confirmation
        nwb.SaveAs Sheet.Parent.Path & Application.PathSeparator & Sheet.Name
    Application.DisplayAlerts = True
    nwb.Close False
End Sub

- VBasic2008

Answer 2

set newWorkbook = workbooks.Add 创建一个新的工作簿。但是不带参数的 ws.Copy 将 ws 复制到一个新的工作簿中。现在你有了两个新的工作簿，这显然不是你想要的结果。微软学习文档在其复制命令的文档中给出了如何复制工作表的示例。参考：https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.copy。

Sub foo()
    Call SaveWorksheetAsXlsx(Worksheets("Sheet3"))
End Sub

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String

    filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
    If Not CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then
        ws.Copy
        ActiveWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close SaveChanges:=False
    Else
        MsgBox "Error: unable to save file. File already exists: " + filePath
    End If
    
 End Sub

这显然依赖于这样一个预期行为，即当您将工作表复制到新工作簿时，该工作簿会成为活动工作簿。我以前使用过这种方法而没有遇到任何问题（我猜已经有很多年了），尽管我有点担心依赖默认行为。因此，您可以考虑添加一些守卫子句，例如仅在工作簿路径为空时保存工作簿（即确保它是新添加的工作簿 -> if ActiveWorkbook.Path = ""）。 因此，编写代码时要非常谨慎和预防性：

Sub foo()
    Call SaveWorksheetAsXlsx(Worksheets("Sheet3"))
End Sub

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String

    filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
    If Not CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then
        ws.Copy
        If ActiveWorkbook.Path = "" Then 'Extra check to ensure this is a newly created and unsaved workbook
            ActiveWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
        Else
            MsgBox "Unexpected error attempting to save file " + filePath
        End If
    Else
        MsgBox "Error: unable to save file. File already exists: " + filePath
    End If
    
 End Sub

- topsail