如何使用vba只複製一個工作表到另一個工作簿

Question

我有1 WorkBook("SOURCE")包含大約20張表。
我想使用Excel VBA僅將1張特定工作表複製到另一個Workbook("TARGET")。

請注意，「TARGET」工作簿還不存在。它應該在運行時創建。

使用的方法 -

1）Activeworkbook.SaveAs < ---不工作。這將複製所有表單。我只想要特定的表格。

請回復這與您的寶貴意見。

謝謝！

Answer 1

我有1個WorkBook（「SOURCE」），其中包含大約20張表。我想使用Excel VBA僅將1張特定工作表複製到另一個工作簿（「TARGET」）。請注意，「TARGET」工作簿還不存在。它應該在運行時創建。

換種方式

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 

這將自動創建一個名爲Target.xlsx有關表新工作簿

Answer 2

將工作表複製到工作簿稱爲目標：

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

這將使複印紙上XYZ在目標工作簿中的表ABC 顯然，如果你想要把該板在後在工作表之前的TARGET工作簿中，替換代碼中的Before for After。

要創建一個稱爲目標工作簿中，你首先需要添加一個新的工作簿，然後將其保存到定義文件名：

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

的要長得多下面的例子結合了上面的一些有用的片段：

• 可以指定任意號碼，你想跨越
• 複製您可以複製整個表，即般劃過拖動標籤，也可以在細胞中的內容複製爲值，僅保留，但格式表。

它仍然可以做很多工作，使其更好（更好的錯誤處理，一般清理），但它有望提供一個良好的開端。

請注意，並非所有格式都會傳送，因爲新工作表使用自己主題的字體和顏色。我無法確定如何在僅粘貼值時複製這些內容。

 
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