Question

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

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

使用的方法 -

1）Activeworkbook.SaveAs＆lt; ---不起作用。这将复制所有工作表。我只想要特定的表格。

请回复此以及您的宝贵意见。

谢谢！

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

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

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

这将在表格 abc 之后将复制的表格 xyz 放入TARGET工作簿显然，如果您想在工作表之前将工作表放在TARGET工作簿中，请在代码中替换Before for After。

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

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

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

希望这会让你有所收获。

Answer 3

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

您可以指定要复制的任意数量的工作表
您可以复制整个工作表，例如将选项卡拖过，或者您可以将单元格的内容复制为仅限值，但保留格式。

它仍然可以做很多工作来使它更好（更好的错误处理，一般清理），但它希望提供一个良好的开端。

请注意，并非所有格式都会被执行，因为新工作表使用自己的主题字体和颜色。我只能在仅作为值粘贴时解决这些问题。

 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

Answer 4

Sub ActiveSheet_toDESKTOP_As_Workbook()

Dim Oldname As String
Dim MyRange As Range
Dim MyWS As String

MyWS = ActiveCell.Parent.Name

    Application.DisplayAlerts = False 'hide confirmation from user
    Application.ScreenUpdating = False
    Oldname = ActiveSheet.Name
    'Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"
    
    'Get path for desktop of user PC
    Path = Environ("USERPROFILE") & "\Desktop"
    

    ActiveSheet.Cells.Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "TransferSheet"
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.Copy
    
    'Create new workbook and past copied data in new workbook & save to desktop
    Workbooks.Add (xlWBATWorksheet)
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells(1, 1).Select
    ActiveWorkbook.ActiveSheet.Name = Oldname    '"report"
    ActiveWorkbook.SaveAs Filename:=Path & "\" & Oldname & " WS " & Format(CStr(Now()), "dd-mmm (hh.mm.ss AM/PM)") & ".xlsx"
    ActiveWorkbook.Close SaveChanges:=True

    
    Sheets("TransferSheet").Delete
    
    
   Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Worksheets(MyWS).Activate
    'MsgBox "Exported to Desktop"

End Sub

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

4 个答案: