如何将活动工作表的内容复制到新工作簿？答案

【问题标题】：How to copy the contents of the active sheet to a new workbook?如何将活动工作表的内容复制到新工作簿？
【发布时间】：2020-01-20 02:18:02
【问题描述】：

我正在尝试将活动工作表的内容复制到新工作簿。

Sub new_workbook()

    Dim ExtBk As Workbook
    Dim ExtFile As String

    Columns("A:N").Copy

    Workbooks.Add.SaveAs Filename:="output.xls"
    ExtFile = ThisWorkbook.Path & "\output.xls"

    Set ExtBk = Workbooks(Dir(ExtFile))
    ExtBk.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

    Application.DisplayAlerts = False
    ExtBk.Save
    Application.DisplayAlerts = True

End Sub

PasteSpecial 行出现错误，主题中指定了错误。我有点困惑，因为如果我将它定向到源工作簿，它就可以工作。

也许我需要使用 Windows(output.xls)？

【问题讨论】：

源工作簿的文件格式是什么？如果您要从 xlsx 转到 xls，您可能会尝试粘贴太多行
嗯。它是一个 xlsx。如果我尝试将其复制到 xlsx，它会起作用吗？
它更有可能工作......
所以如果我尝试使用 xlsx 格式，我会得到一个错误：应用程序定义或对象定义错误
你从哪里得到错误？

标签： excel vba

【解决方案1】：

如果您只关心保存值，则根本不要使用Copy 方法。

Sub new_workbook()
Dim wbMe As Workbook: Set wbMe = ThisWorkbook
Dim ws As Worksheet: Set ws = wbMe.ActiveSheet
Dim ExtBk As Workbook

Set ExtBk = Workbooks.Add
ExtBk.SaveAs Filename:=wbMe.Path & "\output.xls"

ExtBk.Worksheets("Sheet1").Range("A:N").Value = ws.Range("A:N").Value

Application.DisplayAlerts = False
ExtBk.Save
Application.DisplayAlerts = True

End Sub

注意：如果您的 ThisWorkbook 未保存，这将失败（之前的代码也会失败）。

【讨论】：

好电话。通常不需要填充（污染）剪贴板。
是的，在尝试将值设置为相同时，我遇到了同样的错误。
@yatici 你不可能得到“同样的错误”，因为这段代码没有调用PasteSpecial 方法。那么，您遇到了什么错误？
啊哈没关系，好像它喜欢它。我忘了评论pastespecial。这很好。看起来很慢，但绝对方便
速度可能是您复制整个列的函数，因此，12 列 * 1048576 行。大量数据。如果要将范围修改为实际需要复制的较小数据范围（例如，Range("A1:N3502") 等），性能应该会快得多。干杯。

【解决方案2】：

我成功了：

Sub cp2NewWb()
    Dim ExtFile As String
    ExtFile = ThisWorkbook.Path & "output.xls"
    Workbooks.Add.SaveAs Filename:="output.xls"

    Windows("test1.xlsm").Activate
    Range("A1:AA100").Copy
    Windows("output.xls").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Worksheets(Worksheets.Count).Columns("A:AA").EntireColumn.AutoFit
    Range("A1").Select

    Windows("test1.xlsm").Activate
    Application.CutCopyMode = False
    Range("A1").Select
End Sub

我需要在激活窗口之间进行，否则它不起作用。

【讨论】：

【解决方案3】：

如果要复制整个区域，则复制工作表：

Worksheets("Sheet1").Copy Workbooks(2).Worksheets(1)

如果它复制了一些您不需要的列，那么您可以在之后将其删除。

如果您要从 .xlsx 复制到 .xls，则需要使用复制/粘贴：

Worksheets("Sheet1").UsedRange.Copy Workbooks(2).Worksheets(1).Range("A1")

如果需要粘贴值：

Workbooks(2).Worksheets(1).UsedRange.Copy
Workbooks(2).Worksheets(1).Range("A1").PasteSpecial xlPasteValues

请注意，UsedRange 不会从 A1 开始，除非此单元格包含某些内容。在这种情况下，您必须定义一个从 A1 开始并延伸到最后使用的单元格的 Range 对象。

【讨论】：

我可以复制整个工作表，但如果是公式，我需要将特殊粘贴为原始工作簿，并且我希望将结果保存在这个新生成的工作簿中。
@yatici 我在回答中添加了进一步的建议。

【解决方案4】：

Private Sub ExceltoExcel()
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    'Input Data
     Sheets("Sheet1").Cells(1, 1).Select
     col = Sheets("Sheet1").Cells(2, 2)
     Dim exlApp As Excel.Application
     Dim ExtBk As Excel.Workbook
     Dim exlWs As Excel.Worksheet
     ExtFile = ThisWorkbook.Path & "\output.xls"
     Set exlApp = CreateObject("Excel.Application")
     Set ExtBk = exlApp.Workbooks.Open(ExtFile)
     Set exlWs = exlWb.Sheets("Sheet1")
     ExtBk.Activate
     exlWs.Cells(2, 2) = col
     'Output Data
     exlWs.Range("A1").Select
     exlWb.Close savechanges:=True
     Set ecxlWs = Nothing
     Set exlWb = Nothing
     exlApp.Quit
     Set exlApp = Nothing
     Application.EnableEvents = True
     Application.DisplayAlerts = True
End Sub

【讨论】：