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
 

Fichiers joints

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:

Jacky67

XLDnaute Accro
bonjour,
est ce que quelqu'un peut m'aider s'il vous plait ???
Bonjour,
Ceci attribué au bouton" exporter" devrait faire..
Code:
Sub CopyConforme()
    Sheets(Array("1", "2", "3")).Copy
    ActiveSheet.Buttons.Delete
    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "ds.xlsx"
    ActiveWindow.Close
End Sub
JJ
 

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
 

Fichiers joints

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 Jacky67,
le fichier DS s'enregistre dans quel emplacement parce que je ne le trouve pas ??
 

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
 

Fichiers joints

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+
 

Fichiers joints

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+
 

Fichiers joints

susaita

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

Cordialement
Susaita
 

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: [URL='http://s.drawingobjects.delete/']s.DrawingObjects.Delete:[/URL] Next
  .SaveAs ThisWorkbook.Path & "\DS", 51
  .Close
End With
ActiveCell.Activate
End Sub
 

job75

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

job75

XLDnaute Barbatruc
Re,

Pour savoir d'où vient le problème ajoutez un blocage intermédiaire :
Code:
Sub Exporter()
Dim s As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(Array("MO Qte", "BETON Qte", "ACIER Qte")).Copy
Exit Sub 'blocage pour tester
With ActiveWorkbook
  For Each s In .Sheets: s.DrawingObjects.Delete: Next
  .SaveAs ThisWorkbook.Path & "\DS", 51
  .Close
End With
ActiveCell.Activate
End Sub
Si les couleurs du document créé sont modifiées le problème vient de la sélection multiple des 3 feuilles.

Sinon il vient de la commande SaveAs.

Dans les 2 cas ce serait un bug de votre version Windows ou Excel.

Nota : j'espère que les couleurs incriminées ne viennent pas d'une MFC...

A+
 
Dernière édition:

susaita

XLDnaute Occasionnel
re,
les couleurs qui se modifient sont juste celles des lignes 12,23,34,37,40,56,67,77,85,88,91,107
ce sont les lignes qui contiennent les sous.totaux
 

susaita

XLDnaute Occasionnel
oups désolé j'avais pas vu le dernier post
je viens d'essayer le même fichier sur un autre ordi ca me donne le même résultat
je n'utilise pas de MFC non plus
 

susaita

XLDnaute Occasionnel
Bonsoir Job, le Forum
je vous contacte après une longue absence pour solliciter votre aide par rapport au code d'exportation que vous m'avez donné dans ce sujet :

VB:
Sub ExporterDS()
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
j'ai remarqué un petit problème dans le fichier exporté (DS). ce dernier indique un message <<la mise à jour automatique des liens à été désactivé>> et cela m'oblique à chaque fois de me rendre vers données > modifier les liens pour rompre la liaison avec le fichier d'origine.

ma demande c'est d'ajouter une commande à mon code pour éviter ce problème

Merci d'avance
 
Dernière édition:

Discussions similaires


Haut Bas