可以将文章内容翻译成中文,广告屏蔽插件可能会导致该功能失效(如失效,请关闭广告屏蔽插件后再试):
问题:
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.
Methods Used -
1) Activeworkbook.SaveAs
Please reply this with your valuable comments.
Thanks !!
回答1:
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.
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
回答2:
To copy a sheet to a workbook called TARGET:
Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc")
This will put the copied sheet xyz in the TARGET workbook after the sheet abc Obviously if you want to put the sheet in the TARGET workbook before a sheet, replace Before for After in the code.
To create a workbook called TARGET you would first need to add a new workbook and then save it to define the filename:
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.
回答3:
You can try this VBA program
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
回答4:
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