XL 2013 Exporter Onglets dans un nouveau classeur (VBA)

[susaita]

Bonsoir à tous,
dans le fichier ci-inclus j'ai 3 onglets que je veux copier dans un nouveau classeur avec les conditions suivantes :

*le nouveau fichier garde les formules
*le nouvau fichier créé sera fermé
*le nouvau classeur créé prendra DS comme nom
*le fichier créé (DS) je veux qu'il soit dans le même dossier que le fichier ventes
*ne pas garder les boutons qui se trouvent dans les onglets
*ne pas garder le code vba dans le nouveau classeur
*les onglets crées doivent garder leur couleur d'origines (rouge,vert et bleu)
*la hauteur des lignes et la largeur es colonnes restera la même que celle du classeur d'origine

Merci d'avance

 

[susaita]

bonjour,
est ce que quelqu'un peut m'aider s'il vous plait ???

 

[Dranreb]

Bonjour.
Je dirais comme ça à priori :

Sub Exporter()
Dim WbkDst As Workbook
ThisWorkbook.Sheets("1").Copy
Set WbkDst = ActiveWorkbook
ThisWorkbook.Sheets("2").Copy After:=WbkDst.Sheets(1)
ThisWorkbook.Sheets("3").Copy After:=WbkDst.Sheets(2)
WbkDst.ChangeLink Name:=ThisWorkbook.Name, NewName:=WbkDst.Name, Type:=xlExcelLinks
WbkDst.Sheets("1").Shapes("Button 1").Delete
WbkDst.SaveAs Filename:=ThisWorkbook.Path & "\DS.xlsx", _
  FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
WbkDst.Close
End Sub

 

[Jacky67]

bonjour,
est ce que quelqu'un peut m'aider s'il vous plait ???

Bonjour,
Ceci attribué au bouton" exporter" devrait faire..

Sub CopyConforme()
    Sheets(Array("1", "2", "3")).Copy
    ActiveSheet.Buttons.Delete
    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "ds.xlsx"
    ActiveWindow.Close
End Sub

JJ

 

[susaita]

Bonjour Dranreb,
merci tout d'abord pour ta réponse
en appliquant ton code sur mon fichier d'origine que vous trouverez ci-joint j'ai constaté qu'il bloque sur cette ligne

WbkDst.Sheets("MO Qte").Shapes("Button 1").Delete

 

[job75]

Bonjour susaita, Bernard, Jacky67,

Ou aussi :

Sub Exporter()
Dim chemin$
chemin = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs chemin & "DS.xlsm"
With Workbooks.Open(chemin & "DS.xlsm")
  .Sheets(1).DrawingObjects.Delete
  .SaveAs chemin & "DS.xlsx", 51
  .Close
End With
Kill chemin & "DS.xlsm"
End Sub

A+

 

[susaita]

Bonjour Jacky67,
le fichier DS s'enregistre dans quel emplacement parce que je ne le trouve pas ??

 

[susaita]

Bonjour,
ton fichier répond bien à ma demande sauf que quand je l'applique sur mon fichier d'origine il me copie tout les onglets alors que moi je ne veux copier que les onglets (MO Qte, BETON Qte, ACIER Qte)
autre chose le code ne supprime pas tout les codes qui se trouve sur ces trois onglets

 

[Dranreb]

Il n'existe pas de forme dessinée "Button 1" dans le fichier joint.
Le bouton de formulaire qui affiche "EXPORTER" s'appelle "Bouton 2"
Moi je le renommerais "BtnExporter" et j'utiliserais ce nom pour ne pas me tromper.
Notez que vous pouvez aussi prendre WbkDst.Sheets("MO Qte").Shapes(Application.Caller).Delete

 

[job75]

Re,

Comme quoi il faut être précis dès le début dans ses demandes 🙄

Sub Exporter()
Dim chemin$, s As Object
chemin = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs chemin & "DS.xlsm"
With Workbooks.Open(chemin & "DS.xlsm")
  For Each s In .Sheets
    If IsError(Application.Match(s.Name, Array("MO Qte", "BETON Qte", "ACIER Qte"), 0)) _
      Then s.Delete Else s.DrawingObjects.Delete
  Next
  .SaveAs chemin & "DS.xlsx", 51
  .Close
End With
Kill chemin & "DS.xlsm"
End Sub

Fichier joint.

Nota : ma macro du post #6 ne laissait pas de code VBA dans le fichier (.xlsx) créé !!

A+

 

[susaita]

Merci beaucoup Job c'est exactement ce que je voulais

 

[job75]

Re,

J'ai utilisé la méthode précédente pour faire autre chose que mes petits copains 😉

Mais je préfère la méthode de Jacky67 car elle est plus rapide :

Sub Exporter()
Dim s As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(Array("MO Qte", "BETON Qte", "ACIER Qte")).Copy
With ActiveWorkbook
  For Each s In .Sheets: s.DrawingObjects.Delete: Next
  .SaveAs ThisWorkbook.Path & "\DS", 51
  .Close
End With
ActiveCell.Activate
End Sub

Fichier (2).

A+

 

[susaita]

merci encore une autre fois JOB, Jacky, dranreb et a tout ceux qui nous aident sur ce forum

Cordialement
Susaita

 

[susaita]

Bonjour Job,
en appliquant le 2ème code sur mon fichier d'origine il n'exporte pas les mêmes couleurs d'origine est ce que je dois changer quelque chose dans le code ??

Sub Exporter()
Dim s As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(Array("MO Qte", "BETON Qte", "ACIER Qte")).Copy
With ActiveWorkbook
  For Each s In .Sheets: [I]Ce lien n'existe plus[/I] Next
  .SaveAs ThisWorkbook.Path & "\DS", 51
  .Close
End With
ActiveCell.Activate
End Sub

 

[job75]

Bonjour susaita,

Je ne vois vraiment pas pourquoi un "Enregistrer sous" de .xlsm en .xlsx modifierait les couleurs.

Chez moi (Excelcel 2013) je n'observe rien de tel avec le fichier du post #12.

A+