Code VBA Copier 3 onglets dans un nouveau classeur

[Elisa47]

Bonjour le forum,

J’ai un classeur “Exemple” composé de plusieurs onglets dont “Présentation”, “Résultats” et “Amélioration”.
Je voudrais copier ces 3 onglets dans un nouveau classeur qui porterai le nom de la cellule D3 de l’onglet “Projet”.
Ce classeur étant utilisé par d’autres personnes, il faudrait que la personne qui créé le nouveau classeur, puisse choisir le répertoire, où il sera enregistré.
Le bouton de la macro pour réaliser cette tache serait dans l’onglet “Projet”.
Merci d’avance pour votre aide.

 

[Lolote83]

Salut ELISA47,
Voir fichier joint si cela te convient
Cordialement
Lolote83

 

[zebanx]

Bonjour Elisa47, Lolote83, le forum

@Lolote83
Code très agréable, merci .
J'avais toujours des getopenfile pour ouvrir des fichiers mais c'est intéressant de savoir choisir un classeur de destination par ce moyen.
Une petite question (toutefois) : Est-il possible STP de choisir directement le "desktop" ? Cela fonctionne si on choisit de créer un nouveau dossier mais sinon, il y a une msgbox (erreur91).

Je te remercie pour cette précision.
@+

 

[Lolote83]

Salut ZEBANK,
Voici ce que j'ai trouvé sur le net

Sub ChoixRepertoire()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim Chemin As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, "C:\Users\toto\Desktop")

On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
[D4] = Chemin
End Sub

A adapter en fonction de ton nom
@+ Lolote83

 

[zebanx]

Re-

Déjà merci pour ta réponse rapide.
Ca n'a pas fonctionné mais, par tentative, celui-ci à l'air de fonctionner.

@+ et encore bravo pour ton code

Sub SelectRep()
Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", ssfTous)
Set oFolderItem = objFolder.Items.Item
On Error GoTo Nerror
Chemin = oFolderItem.Path

Nerror:
If Err.Number = 91 Then Chemin = "C:\Users\thierry\Desktop"

[D4] = Chemin
Set objShell = Nothing
Set objFolder = Nothing
Set oFolderItem = Nothing

End Sub

 

[Lolote83]

Re salut Zebank,
Si tu remplaces ce qui est en rouge sur le post#4 par C:\Users\thierry\Desktop, cela ne marche pas !!!!
Bref, tu as trouvé apparemment une parade, mais cela me parait bizarre.
@+ Lolote83

 

[zebanx]

Re,

Pour compléter le post #5 par rapport à la réponse en #4 j'ai toujours l'erreur 91 sur la ligne
Chemin = oFolderItem.Path

Mais comme on sait la ligne qui pose problème et le numéro d'erreur, on tente de contourner et ça a bien fonctionné.
Bon, j'utilise beaucoup le desktop pour des essais, mais c'est quelque chose de bien rare pour l'enregistrement de fichiers...
Ton code initial n'en reste pas moins très intéressant et je l'ai comme il se doit sauvegardé.
@+

 

[Elisa47]

Bonjour Lolote83, zebanx, le forum,

Merci beaucoup pour ton aide. C'est parfait.
Très bonne soirée.

 

[Elisa47]

Re-bonjour Lolote83, le forum,

Est-il possible de rajouter dans la macro, une boîte de dialogue avec un message du type "Ce fichier existe déjà, veux-tu le remplacer ?", si "Oui" on remplace le fichier existant, si "Non" on sort de la macro
Merci

 

[Lolote83]

Re bonjour,
Il suffit de mettre à True la ligne suivante
Application.DisplayAlerts = True
@+ Lolote83

 

[Elisa47]

Bonjour Lolote83,
Merci pour ton aide.
J'ai un petit soucis, lorsque Excel me demande si je veux remplacer le fichier existant, si je clique sur annuler, j'ai un message d'erreur :
Microsoft Visual Basic 400.
Le nouveau classeur est créé avec comme nom Classeur(n)
Je ne sais pas comment contourner cette erreur.
Merci encore.

 

[Lolote83]

Re salut ELISA47,
Avec ce nouveau code, si clic sur annuler, rien ne se passe

Sub Transfert()
Application.ScreenUpdating = False
Application.DisplayAlerts = True
[ND_Chemin] = ClearContents
Call ChoixRepertoire
If IsEmpty([ND_Chemin]) = True Then Exit Sub
xChemin = [ND_Chemin]
xFichier = [ND_Fichier]
Sheets(Array("Présentation", "Résultats", "Améliorations")).Copy
ActiveWorkbook.SaveAs Filename:=xChemin & "\" & xFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Application.ScreenUpdating = False
MsgBox "TERMINE", vbInformation, "TRANSFERT"
End Sub

En espérant avoir répondu à ta demande
Cordialement
Lolote83

 

[Elisa47]

Bonjour Lolote83,

Avec ce nouveau code, si je clique sur "non" ou sur "annuler", j'ai le message d'erreur :
"Erreur d'exécution '1004' :
La méthode 'SaveAs' de l'objet '_Workbook' a échoué."
Ça bloque à l'instruction :
ActiveWorkbook.SaveAs Filename:=xChemin & "\" & xFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Encore merci pour ton aide.
Elisa47

 

[Lolote83]

Re salut,
Avec ce nouveau code, cela devrait le faire
Sub Transfert()
On Error GoTo SiErreur
Application.ScreenUpdating = False
Application.DisplayAlerts = True
[ND_Chemin] = ClearContents
Call ChoixRepertoire
If IsEmpty([ND_Chemin]) = True Then Exit Sub
xChemin = [ND_Chemin]
xFichier = [ND_Fichier]
Sheets(Array("Présentation", "Résultats", "Améliorations")).Copy
ActiveWorkbook.SaveAs Filename:=xChemin & "\" & xFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Application.ScreenUpdating = False
MsgBox "TERMINE", vbInformation, "TRANSFERT"
Exit Sub
SiErreur:
ActiveWindow.Close (False)
MsgBox "AUCUN TRANSFERT EFFECTUE", vbInformation, "TRANSFERT"
End Sub
@+ Lolote83

 

[Elisa47]

Re-bonjour Lolote83

Merci beaucoup pour ton aide et tes réponses très rapides.
C'est parfait.
Très bonne journée.
Elisa47