XL 2013 Exporter Onglets dans un nouveau classeur (VBA)

susaita

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

Pièces jointes

  • Ventes.xlsx
    25.3 KB · Affichages: 84
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Je dirais comme ça à priori :
VB:
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
 
Dernière édition:

susaita

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

Pièces jointes

  • Ventes.xlsm
    114.8 KB · Affichages: 71

job75

XLDnaute Barbatruc
Bonjour susaita, Bernard, Jacky67,

Ou aussi :
Code:
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

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

Pièces jointes

  • Ventes.xlsm
    116.5 KB · Affichages: 78

Dranreb

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

XLDnaute Barbatruc
Re,

Comme quoi il faut être précis dès le début dans ses demandes :rolleyes:
Code:
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+
 

Pièces jointes

  • Ventes(1).xlsm
    121.8 KB · Affichages: 97

job75

XLDnaute Barbatruc
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 :
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: s.DrawingObjects.Delete: Next
  .SaveAs ThisWorkbook.Path & "\DS", 51
  .Close
End With
ActiveCell.Activate
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Ventes(2).xlsm
    123.4 KB · Affichages: 104

susaita

XLDnaute Occasionnel
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 ??

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

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 889
Membres
101 831
dernier inscrit
gillec