Excel 创建新工作簿并在上复制工作表

问题集中在一个工作簿上，其中包含了我的所有数据和分布在大量工作表上的细分数据。我正在尝试设置宏，以便将“选择工作表”复制到新工作簿。我认为我最大的问题是为目标工作簿正确编码，因为名称中包含一个每天都在变化的日期字符串。到目前为止，我刚刚创建并关闭新工作簿的代码是：

Sub NewReport()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    MyDate = Date

    Dim dateStr As String
    dateStr = Format(MyDate, "MM-DD-YY")

    Set W = Application.Workbooks.Add

    W.SaveAs Filename:="N:\PAR\" & "New Report Name" & " " & dateStr, FileFormat:=51

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    ActiveWorkbook.Close True
End Sub

这是有效的，并且实现了我想要的关于创建新文档、以应该命名的方式命名它以及在结束时关闭它的功能。我需要帮助的是将特定工作表从原始工作簿复制到新工作簿的中间部分。我当时的想法是：

 With Workbooks("Original Workbook.xlsm")
            .Sheets(Array("Sheet1", "Sheet2")).Copy_ Before:=Workbooks("destination.xls").Sheet1

或者至少是某种类型的数组，以获得我想要复制的内容。最大的难题是目标工作簿路径名是否正确。非常感谢您对这个小项目的各个部分或整体提出的任何建议。谢谢

---

编辑：我还需要指出的是，正在生成的新工作簿需要是纯旧excel格式（.xlsx）。没有宏，没有自动更新链接或启用宏的安全警告，zip。我告诉它放在那个里的只是一本普通的活页簿。

你们的复印行应该是

Workbooks("Original Workbook.xlsm").Sheets(Array("Sheet1", "Sheet2")).Copy _
 Before:=W.Sheets(1)

---

您可以使代码完全可变，而不是对“Orginal Workbook.xlsm”以及Sheet1和Sheet2名称进行编码

如果使用两个工作簿变量，则可以将ActiveWorbook（即当前在Excel中选择的工作簿）设置为要复制的工作簿（或者可以将其设置为关闭的工作簿、现有的打开命名工作簿或包含代码的工作簿）

有标准

Application.Workbooks.Add

您将获得一个新工作簿，其中按照默认选项安装了张数（通常为3张） 通过指定

 Application.Workbooks.Add(1)

仅使用一张工作表创建新工作簿

注意，我通过将EnableEvents设置为False禁用了宏，但在创建工作簿时运行应用程序事件是不常见的

然后在复制图纸时使用

 Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name)).Copy 
 'rather than
 Sheets(Array("Sheet1", "Sheet2")).Copy

避免对要复制的图纸名称进行硬编码。此代码将复制最左边的两张图纸，而不考虑命名

最后，删除最初的一张图纸，留下一个新文件，其中只有两张复制的图纸

Sub NewReport()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim dateStr As String
    Dim myDate As Date

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Set Wb1 = ActiveWorkbook

    myDate = Date

    dateStr = Format(myDate, "MM-DD-YY")

    Set Wb2 = Application.Workbooks.Add(1)
    Wb1.Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name)).Copy Before:=Wb2.Sheets(1)
    Wb2.Sheets(Wb2.Sheets.Count).Delete
    Wb2.SaveAs Filename:="c:\test\" & "New Report Name" & " " & dateStr, FileFormat:=51

    Wb2.Close
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

---

嗯。我终于让它工作了。工作表名称被带出（否则我将不得不走到后面并重命名它们）；它保存了一份要发送的副本和一份到我们的存档文件夹中的副本；新的工作手册没有关于启用宏或更新链接的弹出窗口。我最终确定的代码（可能会稍微修剪一下）是：

---

希望这能帮助其他人解决同样的问题

获取错误消息：此对象不支持此属性或方法。好吧，现在它是一条新的错误消息-它说它无法复制工作表，因为目标没有相同的行数和列数，如果我要移动数据，那么我应该复制并粘贴它。Jon，您是否按原样使用上面的代码？它复制整个工作表，所以我不明白为什么会有关于行和列的消息（这通常是一个范围复制问题）。我唯一更改的是SaveAs行的文件路径。我把其他一切都保持不变，以确保我没有错误地更改某些内容。我试着阅读有关错误消息的内容，我能说的最好的是，可能与将其保存为.xlsx exptension而不是.xlms有关。仍然在摆弄它，但没有运气。

Sub Report()

    Dim Wb1 As Workbook
    Dim dateStr As String
    Dim myDate As Date
    Dim Links As Variant
    Dim i As Integer

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    Set Wb1 = ActiveWorkbook

    myDate = Date

    dateStr = Format(myDate, "MM-DD-YYYY")

    Wb1.Sheets(Array("Sheet1Name", "Sheet2Name", "etc."))Copy

    With ActiveWorkbook
    Links = .LinkSources(xlExcelLinks)
    If Not IsEmpty(Links) Then
        For i = 1 To UBound(Links)
            .BreakLink Links(i), xlLinkTypeExcelLinks
        Next i
    End If

    End With

    ActiveWorkbook.SaveAs Filename:="N:\" & "Report Name" & " " & dateStr, FileFormat:=51
    ActiveWorkbook.SaveAs Filename:="N:\Report Archive\" & "Report Name" & " " & dateStr, FileFormat:=51

    ActiveWorkbook.Close

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub