vba 如何使用vba仅将单个工作表复制到另一个工作簿
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/20246465/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to copy only a single worksheet to another workbook using vba
提问by Solution Seeker
I have 1 WorkBook("SOURCE")
that contains around 20 Sheets.
I want to copy only 1 particular sheet to another Workbook("TARGET")
using Excel VBA.
我有 1 个WorkBook("SOURCE")
,其中包含大约 20 张。
我只想Workbook("TARGET")
使用 Excel VBA 将一张特定的工作表复制到另一个工作表。
Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
请注意,“目标”工作簿尚不存在。它应该在运行时创建。
Methods Used -
使用的方法 -
1) Activeworkbook.SaveAs
<--- Doesn't work. This will copy all the sheets. I want only specific sheet.
1) Activeworkbook.SaveAs
<--- 不起作用。这将复制所有工作表。我只想要特定的表。
回答by Siddharth Rout
I have 1 WorkBook("SOURCE") that contains around 20 Sheets. I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA. Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
我有 1 个 WorkBook(“SOURCE”),其中包含大约 20 张。我只想使用 Excel VBA 将 1 个特定工作表复制到另一个工作簿(“目标”)。请注意,“目标”工作簿尚不存在。它应该在运行时创建。
Another Way
其它的办法
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
This will automatically create a new workbook called Target.xlsx with the relevant sheet
这将使用相关工作表自动创建一个名为 Target.xlsx 的新工作簿
回答by Neil
To copy a sheet to a workbook called TARGET:
要将工作表复制到名为 TARGET 的工作簿:
Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc")
This will put the copied sheet xyzin the TARGET workbook after the sheet abcObviously if you want to put the sheet in the TARGET workbook before a sheet, replace Before for After in the code.
这会将复制的工作表xyz放在工作表abc之后的 TARGET 工作簿中 显然,如果要将工作表放在 TARGET 工作簿中的工作表之前,请将代码中的 Before 替换为 After。
To create a workbook called TARGET you would first need to add a new workbook and then save it to define the filename:
要创建名为 TARGET 的工作簿,您首先需要添加一个新工作簿,然后将其保存以定义文件名:
Application.Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.SaveAs ("TARGET")
However this may not be ideal for you as it will save the workbook in a default location e.g. My Documents.
但是,这对您来说可能并不理想,因为它会将工作簿保存在默认位置,例如我的文档。
Hopefully this will give you something to go on though.
希望这会给你一些事情继续下去。
回答by user8002923
You can try this VBA program
你可以试试这个 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
回答by user535673
The much longer example below combines some of the useful snippets above:
下面更长的例子结合了上面的一些有用的片段:
- You can specify any number of sheets you want to copy across
- You can copy entire sheets, i.e. like dragging the tab across, or you can copy over the contents of cells as values-only but preserving formatting.
- 您可以指定要复制的任意数量的工作表
- 您可以复制整个工作表,例如拖动选项卡,或者您可以将单元格的内容复制为仅值但保留格式。
It could still do with a lot of work to make it better (better error-handling, general cleaning up), but it hopefully provides a good start.
它仍然可以做很多工作来使它变得更好(更好的错误处理,一般清理),但它希望提供一个好的开始。
Note that not all formatting is carried across because the new sheet uses its own theme's fonts and colours. I can't work out how to copy those across when pasting as values only.
请注意,并非所有格式都会进行,因为新工作表使用其自己的主题字体和颜色。我无法弄清楚如何在仅作为值粘贴时复制这些内容。
Option Explicit Sub copyDataToNewFile() Application.ScreenUpdating = False ' Allow different ways of copying data: ' sheet = copy the entire sheet ' valuesWithFormatting = create a new sheet with the same name as the ' original, copy values from the cells only, then ' apply original formatting. Formatting is only as ' good as the Paste Special > Formats command - theme ' colours and fonts are not preserved. Dim copyMethod As String copyMethod = "valuesWithFormatting" Dim newFilename As String ' Name (+optionally path) of new file Dim themeTempFilePath As String ' To temporarily save the source file's theme Dim sourceWorkbook As Workbook ' This file Set sourceWorkbook = ThisWorkbook Dim newWorkbook As Workbook ' New file Dim sht As Worksheet ' To iterate through sheets later on. Dim sheetFriendlyName As String ' To store friendly sheet name Dim sheetCount As Long ' To avoid having to count multiple times ' Sheets to copy over, using internal code names as more reliable. Dim colSheetObjectsToCopy As New Collection colSheetObjectsToCopy.Add Sheet1 colSheetObjectsToCopy.Add Sheet2 ' Get filename of new file from user. Do newFilename = InputBox("Please Specify the name of your new workbook." & vbCr & vbCr & "Either enter a full path or just a filename, in which case the file will be saved in the same location (" & sourceWorkbook.Path & "). Don't use the name of a workbook that is already open, otherwise this script will break.", "New Copy") If newFilename = "" Then MsgBox "You must enter something.", vbExclamation, "Filename needed" Loop Until newFilename > "" ' If they didn't supply a path, assume same location as the source workbook. ' Not perfect - simply assumes a path has been supplied if a path separator ' exists somewhere. Could still be a badly-formed path. And, no check is done ' to see if the path actually exists. If InStr(1, newFilename, Application.PathSeparator, vbTextCompare) = 0 Then newFilename = sourceWorkbook.Path & Application.PathSeparator & newFilename End If ' Create a new workbook and save as the user requested. ' NB This fails if the filename is the same as a workbook that's ' already open - it should check for this. Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet) newWorkbook.SaveAs Filename:=newFilename, _ FileFormat:=xlWorkbookDefault ' Theme fonts and colours don't get copied over with most paste-special operations. ' This saves the theme of the source workbook and then loads it into the new workbook. ' BUG: Doesn't work! '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 'On Error Resume Next 'Kill themeTempFilePath ' kill = delete in VBA-speak 'On Error GoTo 0 ' getWorksheetNameFromObject returns null if the worksheet object doens't ' exist For Each sht In colSheetObjectsToCopy sheetFriendlyName = getWorksheetNameFromObject(sourceWorkbook, sht) Application.StatusBar = "VBL Copying " & sheetFriendlyName If Not IsNull(sheetFriendlyName) Then Select Case copyMethod Case "sheet" sourceWorkbook.Sheets(sheetFriendlyName).Copy _ After:=newWorkbook.Sheets(newWorkbook.Sheets.count) Case "valuesWithFormatting" newWorkbook.Sheets.Add After:=newWorkbook.Sheets(newWorkbook.Sheets.count), _ Type:=sourceWorkbook.Sheets(sheetFriendlyName).Type sheetCount = newWorkbook.Sheets.count newWorkbook.Sheets(sheetCount).Name = sheetFriendlyName ' Copy all cells in current source sheet to the clipboard. Could copy straight ' to the new workbook by specifying the Destination parameter but in this case ' we want to do a paste special as values only and the Copy method doens't allow that. 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 End Select End If Next sht Application.StatusBar = False Application.ScreenUpdating = True ActiveWorkbook.Save