Comment copier une seule feuille de calcul dans un autre classeur à l'aide de vba

Question

J'ai 1 WorkBook("SOURCE") qui contient environ 20 feuilles.
Je souhaite copier une seule feuille dans un autre Workbook("TARGET") à l'aide d'Excel VBA. 

Veuillez noter que le classeur "CIBLE" n'existe pas encore. Il devrait être créé au moment de l'exécution.

Méthodes utilisées -  

1) Activeworkbook.SaveAs <--- Ne fonctionne pas. Cela va copier toutes les feuilles. Je veux seulement une feuille spécifique.

S'il vous plaît répondez à cela avec vos précieux commentaires.

Merci !!

Answer 1

J'ai 1 classeur ("SOURCE") qui contient environ 20 feuilles. Je souhaite copier uniquement une feuille dans un autre classeur ("CIBLE") à l'aide d'Excel VBA. Veuillez noter que le classeur "CIBLE" n'existe pas encore. Il devrait être créé au moment de l'exécution.

Autrement

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

Cela créera automatiquement un nouveau classeur appelé Target.xlsx avec la feuille correspondante.

Answer 2

Pour copier une feuille dans un classeur appelé TARGET:

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

Cela placera la feuille copiée xyz dans le classeur TARGET après la feuille abc Évidemment, si vous souhaitez placer la feuille dans le classeur TARGET avant une feuille, remplacez Avant pour Après dans le code.

Pour créer un classeur appelé TARGET, vous devez d'abord ajouter un nouveau classeur, puis l'enregistrer pour définir le nom du fichier:

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

Toutefois, cela peut ne pas être idéal pour vous car cela enregistrera le classeur dans un emplacement par défaut, par exemple. Mes documents.

Espérons que cela vous donnera quelque chose à continuer.

Answer 3

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

Answer 4

Vous pouvez essayer ce programme 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