Code VBA Copier 3 onglets dans un nouveau classeur

L

Lolote83

XLDnaute Barbatruc

• 27 Novembre 2018

• #2

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

 

Pièces jointes

• Copie de ELISA47 - Importation.xlsm

  26.8 KB · Affichages: 36

Vote positif 0 Vote négatif

zebanx

XLDnaute Accro

• 27 Novembre 2018

• #3

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.
@+

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 27 Novembre 2018

• #4

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

 

Vote positif 0 Vote négatif

zebanx

XLDnaute Accro

• 27 Novembre 2018

• #5

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

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 27 Novembre 2018

• #6

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

 

Vote positif 0 Vote négatif

zebanx

XLDnaute Accro

• 27 Novembre 2018

• #7

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: 27 Novembre 2018

Vote positif 0 Vote négatif

E

Elisa47

XLDnaute Nouveau

• 27 Novembre 2018

• #8

Bonjour Lolote83, zebanx, le forum,

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

 

Vote positif 0 Vote négatif

E

Elisa47

XLDnaute Nouveau

• 27 Novembre 2018

• #9

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

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 28 Novembre 2018

• #10

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

 

Vote positif 0 Vote négatif

E

Elisa47

XLDnaute Nouveau

• 28 Novembre 2018

• #11

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.

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 29 Novembre 2018

• #12

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

 

Vote positif 0 Vote négatif

E

Elisa47

XLDnaute Nouveau

• 29 Novembre 2018

• #13

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

 

Vote positif 0 Vote négatif

L

Lolote83

XLDnaute Barbatruc

• 29 Novembre 2018

• #14

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

 

Vote positif 0 Vote négatif

E

Elisa47

XLDnaute Nouveau

• 29 Novembre 2018

• #15

Re-bonjour Lolote83

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

 

Vote positif 0 Vote négatif