Sauvegarder une feuille d'un classeur dans un nouveau classeur

Bonjour,

J'ai un fichier nommé "Test", je voudrais copier ma feuille "Alpes Provences" et la sauvegarder dans un nouveau classeur qui va être enregistré dans le même dossier que mon fichier "Test" ou dans un dossier que je pourrai choisir.

Quelqu'un peut il m'aider svp ?

Merci d'avance.

Je sais pas si c'est ce que tu veux

remplace le .xls par .gif

Crdlmt

Bonsoir muqtadir, bonsoir DJIDJI, bonsoir le forum

Une proposition

cordialement

beaux rêves pour tout le monde

Bonjour à tous,

Je tente aussi une proposition surtout pour l'exposer directement afin que ceux ayant le même besoin puissent avoir une idée du principe. Je précise que je n'ai pas vu les solutions apportées par chindou et Djidji.

Copie de la feuille active dans le dossier courant (du classeur actif) :

Sub CopieFeuilleLocale()

Dim NomNv$

With Activesheet 'avec feuille active
    NomNv = "Sauvegarde "& .name & " " & format(Now, "YYMMDD") &".xlsx" 'nom de fichier à créer (ici, avec nom de feuille d'origine et date)
    .copy 'copie dans un nouveau classeur (qui devient classeur actif)
end with

Activeworkbook.close savechanges:=true, Filename:=NomNv 'fermeture et sauvegarde du nouveau classeur dans le dossier courant

Msgbox "Copie réalisée dans :" & vbcrlf & vbcrlf & Thisworkbook.path

End sub

Dans un dossier sélectionné manuellement :

Sub CopieFeuilleAilleurs()

Dim NomNv$, PathNv$

With Application.FileDialog(msoFileDialogFolderPicker)
    .Show 'ouverture boite de dialogue de sélection de dossier
    If .SelectedItems.Count > 0 Then 'si sélection OK
        PathNv = .SelectedItems(1) 'chemin correspond au dossier sélectionné
    End If
End With

With Activesheet 'avec feuille active
    NomNv = PathNv & "\" & "Sauvegarde "& .name & " " & format(Now, "YYMMDD") &".xlsx" 'nom complet du fichier
    .copy
end with

Activeworkbook.close savechanges:=true, Filename:=NomNv 'fermeture et sauvegarde dans dossier sélectionné

Msgbox "Copie réalisée dans :" & vbcrlf & vbcrlf & PathNv

End sub

Enfin, pour avoir le choix entre ces 2 options (en utilisant les 2 macros précédentes) :

Sub CopieFeuille()

Dim Message$, Titre$
Dim Choix as integer

Message = "Voulez-vous copier la feuille active dans le dossier courant ?" & vbcrlf & vbcrlf & _
"Cliquez sur 'Non' pour sélectionner le dossier de destination." 'message de la boite dialogue
Titre = "Choix du répertoire de la copie" 'titre boite dial
Choix = msgbox(Message, vbyesnocancel, Titre) 'valeur retournée suite au choix de l'utilisateur

Select case Choix
    Case vbyes: call CopieFeuilleLocale 'cas OUI : execution macro 1
    Case vbno: call CopieFeuilleAilleurs 'cas NON : execution macro 2
    case else: Msgbox "Copie annulée" 'sinon, cas annul : rien
end select

End sub

Je n'ai pas pu tester les 2 derniers codes mais j'ai bon espoir...

Cordialement,

Bonjour, Chindou, Djidji, 3GB et merci pour votre aide.

Djidji, ton fichier je n'arrive pas à l'ouvrir.

J'ai un morceau de code qui correspond beaucoup plus à ce que je veux, sauf que le fichier obtenu ne garde pas la même mise en forme. je n'arrive donc pas à faire le collage spécial format pour que la mise en forme soit bonne.

Avec ce code, j'enregistre séparément les feuilles Alpes Provence et Corse, mais je veux qu'elle garde leur mise en forme.

Pouvez vous m'aider svp?

Merci

Sub exporter()
Dim f As Worksheet
Dim xl As Excel.Application, wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog

    feuilles = Array("Alpes Provence", "Corse")

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)

    Set xl = CreateObject("Excel.Application")
    xl.SheetsInNewWorkbook = 1

    For i = 0 To UBound(feuilles)
        Set f = Sheets(feuilles(i))
        f.Cells.Copy
        Debug.Print f.Name, f.Range("A1")
        Set wb = xl.Workbooks.Add
        wb.Sheets(1).Paste
        wb.SaveAs (MonRepertoire & "\" & "Analyse Parc ATM_" & f.Name & ".xlsx")
        wb.Close
        Set wb = Nothing
    Next
    xl.Quit
    Set xl = Nothing
    MsgBox "Terminé !"

End Sub

Bonjour Muqtadir,

Voici comment je tournerais ce code pour ma part, pour avoir valeurs et formats.

Sub exporter()

Dim f As Worksheet
Dim MonRepertoire, Repertoire As FileDialog

    feuilles = Array("Alpes Provence", "Corse")

    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)

    For i = 0 To UBound(feuilles)
        Set f = Sheets(feuilles(i))
        f.Copy
        'PARTIE UTILE QUE POUR COLLAGE SPECIAL SANS FORMULES
        with Activeworkbook.Sheets(1).cells
            .copy
            .pastespecial paste:=xlpastevalues
            .pastespecial paste:=xlpasteformats
        end with
        'FIN PARTIE
        wb.Close savechanges:=true, filename:=MonRepertoire & "\" & "Analyse Parc ATM_" & f.Name & ".xlsx"
    Next

    MsgBox "Terminé !"

End Sub

Cordialement,

Merci 3GB pour ta réponse. j'ai une erreur sur cette partie, aurais tu une idée de la cause stp?

wb.Close savechanges:=True, Filename:=MonRepertoire & "\" & "Analyse Parc ATM_" & f.Name & ".xlsx"

Oui, c'est ma précipitation, sans doute... Comme ça, ça devrait être mieux, enfin j'espère

Activeworkbook.Close savechanges:=True, Filename:=MonRepertoire & "\" & "Analyse Parc ATM_" & f.Name & ".xlsx"

le code fonctionne très bien, merci à toi 3GB. :)