Code VBA Copier 3 onglets dans un nouveau classeur

Elisa47

XLDnaute Nouveau
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.
 

Fichiers joints

zebanx

XLDnaute Accro
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

XLDnaute Accro
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

XLDnaute Accro
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


VB:
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

XLDnaute Accro
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

XLDnaute Accro
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é.
@+
 
Dernière édition:

Elisa47

XLDnaute Nouveau
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
 

Elisa47

XLDnaute Nouveau
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

XLDnaute Accro
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

XLDnaute Nouveau
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

XLDnaute Accro
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

XLDnaute Nouveau
Re-bonjour Lolote83

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