vba 创建新工作簿并复制工作表

Creating a new workbook and copying worksheets over

提问by Jon

The problem in question centers around one workbook which contains all of my data and breakdowns spread across a ton of worksheets. I'm trying to get macros set up to copy select sheets to a new workbook. I think my biggest problem is getting the coding right for the destination workbook since the name includes a date string that changes each day. The code that I've got so far to just create the new workbook and close it is:

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

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

This works and does what I want in regards to creating the new document, naming it the way it should be named, and at the end closing it. What I need help with is that middle portion for copying specific sheets from the original workbook to this new one. What I was thinking was along the lines of:

这在创建新文档、以它应该命名的方式命名以及最后关闭它方面有效并完成了我想要的操作。我需要帮助的是将特定工作表从原始工作簿复制到新工作簿的中间部分。我在想的是：

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

Or at least some type of array to get exactly what I want to copy over. The biggest sticking point is getting the destination workbook path name correct. Any advice regarding individual pieces of this little project or on the whole is greatly appreciated. Thanks!

或者至少是某种类型的数组来获得我想要复制的内容。最大的症结是让目标工作簿路径名正确。非常感谢关于这个小项目的个别部分或整体的任何建议。谢谢！

EDIT: I also need to point out that the new workbook being generated needs to be just plain old excel format (.xlsx). No macros, no security warning for automatic updating links or enabling macros, zip. Just a plain book of the sheets I tell it to put there.

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

采纳答案by Jon

Ok. I finally got it working now. Sheet names are carried over (otherwise I would have to go behind and rename them); it saves one copy to be sent and one copy to our archive folder; and the new workbooks don't get any popup about enabling macros or updating links. The code I finally settled on (which could probably be trimmed a little) is:

好的。我现在终于让它工作了。工作表名称被保留（否则我将不得不去重命名它们）；它保存一份要发送的副本，一份副本保存到我们的存档文件夹中；并且新的工作簿没有关于启用宏或更新链接的任何弹出窗口。我最终确定的代码（可能会稍微修剪一下）是：

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

Hope that'll help someone else with the same issue!

希望这会帮助其他有同样问题的人！

回答by chris neilsen

Your copy line should be

你的复制行应该是

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

回答by brettdj

You can make your code fully variable rather than harcoding "Orginal Workbook.xlsm" and the Sheet1 and Sheet2 names

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

If you use two Workbook variables then you can set the ActiveWorbook(ie the one currently selected in Excel) as the workbook to be copied (alternatively you can set it to a closed workbook, existing open named workbook, or the workbook that contains the code).

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

With a standard

有标准的

Application.Workbooks.Add

you will get a new workbook with the number of sheets installed as per your default option (normnally 3 sheets) By specifying

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

 Application.Workbooks.Add(1)

a new workbook is created with only one sheet

只用一张纸创建了一个新工作簿

And note I disabled macros by setting EnableEvents to False but it would be unusual to have application events running when creating workbooks

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

Then when copying the sheet use

然后在复制工作表时使用

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

to avoid hardcoding the sheet names to be copied. This code will copy the two leftmoast sheets irrespective of naming

以避免对要复制的工作表名称进行硬编码。无论命名如何，此代码都将复制两个 leftmoast 表

Lastly the initial single sheet is removed leaving you with a new file with only the two copied sheets inside

最后，最初的单张纸被删除，留下一个新文件，里面只有两张复制的纸

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