如何使用vba将只有一个工作表复制到另一个工作簿

我有1个WorkBook("SOURCE") ，其中包含大约20张表。
我想使用Excel VBA只复制一个特定工作表到另一个Workbook("TARGET") 。

请注意，“TARGET”工作簿还不存在。 它应该在运行时创build。

使用的方法 –

1） Activeworkbook.SaveAs <—不起作用。 这将复制所有表单。 我只想要特定的表格。

请回复这个宝贵的意见。

谢谢 ！！

Answer 1

我有1个WorkBook（“SOURCE”），其中包含大约20张表。 我想使用Excel VBA只复制一个特定工作表到另一个工作簿（“TARGET”）。 请注意，“TARGET”工作簿还不存在。 它应该在运行时创build。

其他方式

 Sub Sample() '~~> Change Sheet1 to the relevant sheet '~~> This will create a new workbook with the relevant sheet ThisWorkbook.Sheets("Sheet1").Copy '~~> Save the new workbook ActiveWorkbook.SaveAs "C:\Target.xlsx", FileFormat:=51 End Sub 

这将自动创build一个名为Target.xlsx的新工作簿和相关工作表

Answer 2

将工作表复制到名为TARGET的工作簿中：

 Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc") 

这将把复制的工作表xyz放到工作表abc后的TARGET工作簿中。显然，如果你想把工作表放到TARGET工作簿之前，在代码中replaceBefore for After。

要创build一个名为TARGET的工作簿，首先需要添加一个新的工作簿，然后保存它以定义文件名：

 Application.Workbooks.Add (xlWBATWorksheet) ActiveWorkbook.SaveAs ("TARGET") 

但是，这可能不适合您，因为它会将工作簿保存在默认位置，例如我的文档。

希望这会给你一些继续。

Answer 3

你可以试试这个VBA程序

 Option Explicit Sub CopyWorksheetsFomTemplate() Dim NewName As String Dim nm As Name Dim ws As Worksheet If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ "New sheets will be pasted as values, named ranges removed" _ , vbYesNo, "NewCopy") = vbNo Then Exit Sub With Application .ScreenUpdating = False ' Copy specific sheets ' *SET THE SHEET NAMES TO COPY BELOW* ' Array("Sheet Name", "Another sheet name", "And Another")) ' Sheet names go inside quotes, seperated by commas On Error GoTo ErrCatcher Sheets(Array("Sheet1", "Sheet2")).Copy On Error GoTo 0 ' Paste sheets as values ' Remove External Links, Hperlinks and hard-code formulas ' Make sure A1 is selected on all sheets For Each ws In ActiveWorkbook.Worksheets ws.Cells.Copy ws.[A1].PasteSpecial Paste:=xlValues ws.Cells.Hyperlinks.Delete Application.CutCopyMode = False Cells(1, 1).Select ws.Activate Next ws Cells(1, 1).Select ' Remove named ranges For Each nm In ActiveWorkbook.Names nm.Delete Next nm ' Input box to name new file NewName = InputBox("Please Specify the name of your new workbook", "New Copy") ' Save it with the NewName and in the same directory as original ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls" ActiveWorkbook.Close SaveChanges:=False .ScreenUpdating = True End With Exit Sub ErrCatcher: MsgBox "Specified sheets do not exist within this workbook" End Sub 

Answer 4

下面更长的例子结合了上面的一些有用的片段：

• 您可以指定要复制的任意数量的工作表
• 您可以复制整个工作表，即像拖动标签一样，也可以复制单元格的内容作为值，但保留格式。

它仍然可以做很多工作，使其更好（更好的error handling，一般清理），但它有希望提供一个良好的开端。

请注意，并非所有的格式都被传送，因为新的工作表使用自己的主题的字体和颜色。 我不能解决如何复制那些粘贴为值只。

 选项显式

 Sub copyDataToNewFile（）
     Application.ScreenUpdating = False

     '允许不同的方式复制数据：
     'sheet =复制整个工作表
     'valuesWithFormatting =创build一个新名字与
     '原来，只从单元格复制值，然后
     '应用原始格式。 格式只是
    像Paste Special> Formats命令 - 主题一样好
     '颜色和字体不会保留。
     Dim copyMethod As String
     copyMethod =“valuesWithFormatting”

     Dim newFilename As String'Name（+ optional path）of new file
     Dim themeTempFilePath As String'暂时保存源文件的主题

     Dim sourceWorkbook As Workbook'这个文件
    设置sourceWorkbook = ThisWorkbook

     Dim newWorkbook As Workbook'新build文件

     Dim sht As Worksheet'稍后迭代表单。
     Dim sheetFriendlyName As String'存储友好图纸名称
     Dim sheetCount As Long'为了避免必须多次计数

     '表格复制，使用内部代码名称更可靠。
     Dim colSheetObjectsToCopy作为新集合
     colSheetObjectsToCopy.Add Sheet1
     colSheetObjectsToCopy.Add Sheet2

     '从用户获取新文件的文件名。
    做
         newFilename = InputBox（“请指定新工作簿的名称。”＆vbCr＆vbCr＆“input一个完整path或只是一个文件名，在这种情况下，文件将被保存在相同的位置（”＆sourceWorkbook.Path＆ “）。不要使用已打开的工作簿的名称，否则该脚本将中断。”，“新build”）
        如果newFilename =“”那么MsgBox“你必须input一些东西”，vbExclamation，“需要的文件名”
    循环直到newFilename>“”

     '如果他们没有提供path，则假定与源工作簿位置相同。
     “不完美 - 只是假设path已经提供，如果path分隔符
     “存在某处。 可能仍然是一个糟糕的path。 而且，没有检查完成
    看看path是否真的存在。
    如果InStr（1，newFilename，Application.PathSeparator，vbTextCompare）= 0那么
         newFilename = sourceWorkbook.Path＆Application.PathSeparator＆newFilename
    万一

     '创build一个新的工作簿并保存为用户请求。
     'NB如果文件名与工作簿相同，则失败
     “已经打开 - 它应该检查这个。
    设置newWorkbook = Application.Workbooks.Add（xlWBATWorksheet）
     newWorkbook.SaveAs文件名：= newFilename，_
        的FileFormat：= xlWorkbookDefault

    主题字体和颜色不会被复制到大多数粘贴特殊操作。
    这将保存源工作簿的主题，然后将其加载到新的工作簿中。
     '错误：不起作用！
     'themeTempFilePath = Environ（“temp”）＆Application.PathSeparator＆sourceWorkbook.Name＆“ -  Theme.xml”
     'sourceWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
     'sourceWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
     'newWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
     'newWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
     '在错误恢复下一步
    杀死themeTempFilePath'kill =在VBA中删除说话
     '在错误转到0


     'getWorksheetNameFromObject返回null如果工作表对象doens't
     '存在
    对于每个sht在colSheetObjectsToCopy中
         sheetFriendlyName = getWorksheetNameFromObject（sourceWorkbook，sht）
         Application.StatusBar =“VBL复制”＆sheetFriendlyName
        如果不是IsNull（sheetFriendlyName）那么
            select案例copyMethod
                案例“表”
                     sourceWorkbook.Sheets（sheetFriendlyName）.Copy _
                        后：= newWorkbook.Sheets（newWorkbook.Sheets.count）
                案例“valuesWithFormatting”
                     newWorkbook.Sheets.Add After：= newWorkbook.Sheets（newWorkbook.Sheets.count），_
                        types：= sourceWorkbook.Sheets（sheetFriendlyName）。键入
                     sheetCount = newWorkbook.Sheets.count
                     newWorkbook.Sheets（sheetCount）.Name = sheetFriendlyName
                     '将当前源表中的所有单元格复制到剪贴板。 可以直接复制
                    通过指定目的地参数，但在这种情况下，新工作簿
                     '我们想要做一个特殊的粘贴，只有值和复制方法不允许。
                     sourceWorkbook.Sheets（sheetFriendlyName）.Cells.Copy'Destination：= newWorkbook.Sheets（newWorkbook.Sheets.Count）。[A1]
                     newWorkbook.Sheets（sheetCount）。[A1] .PasteSpecial Paste：= xlValues
                     newWorkbook.Sheets（sheetCount）。[A1] .PasteSpecial Paste：= xlFormats
                     newWorkbook.Sheets（sheetCount）.Tab.Color = sourceWorkbook.Sheets（sheetFriendlyName）.Tab.Color
                     Application.CutCopyMode = False
            结束select
        万一
    接下来转

     Application.StatusBar = False
     Application.ScreenUpdating = True
     ActiveWorkbook.Save