Enregistrer deux onglets sur dix

[maval]

Bonjour,

Je suis a la recherche d'un code VBA pour enregistrer deux onglets sur dix.

Je m'explique j'ai un fichier avec 10 onglets j'aimerais que lorsque j'enregistre seul les deux premier onglet sois enregistrer.

je vous remercie de votre aide

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

Non il y a toujours les shapes qui sont supprimer.

J'ai joint un fichier pour exemple

Merci d'avance

 

[job75]

Re : Enregistrer deux onglets sur dix

Re,

Bah il n'y a que des objets Formulaire, avec 1240 posts vous pouviez adapter tout seul :

Sub Archiver()
Dim ext$, chemin$, nomfich$, formatfich, o As Object
ext = ".xlsm" '.xlsx '.xls 'à adapter
chemin = ThisWorkbook.Path & "\" '"C:\Users\Max\Desktop\Test\"
nomfich = ThisWorkbook.Sheets(1).[K1]
formatfich = xlWorkbookNormal
If Val(Application.Version) >= 12 Then _
formatfich = IIf(ext = ".xls", 56, IIf(ext = ".xlsm", 52, 51))
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
ThisWorkbook.Sheets(1).Copy
With ActiveWorkbook
  ThisWorkbook.Sheets(2).Copy After:=.Sheets(1)
  For Each o In .Sheets(1).DrawingObjects
    If o.Name <> "dudu" And Not o.Name Like "SP*" Then o.Delete
  Next
  .Sheets(1).Activate
  On Error Resume Next 'si nomfich n'est pas autorisé
  .SaveAs chemin & nomfich, formatfich
  .Close False
End With
End Sub

A+

 

[Pierrot93]

Re : Enregistrer deux onglets sur dix

Bonjour à tous,

pour supprimer les boutons contrôles de formulaire :

Sub Test()
Dim b As Button
For Each b In Feuil1.Buttons
    If b.Name <> "dudu" Then b.Delete
Next b
End Sub

fonctionne chez moi sur ton fichier sous 2010...

bon après midi
@+

 

[job75]

Re : Enregistrer deux onglets sur dix

Post annulé...

 

[maval]

Re : Enregistrer deux onglets sur dix

POUR JOB75,

Voici le Code/

Sub Archiver()
Dim ext$, chemin$, nomfich$, formatfich, o As Object
ext = ".xlsm" '.xlsx '.xls 'à adapter
chemin = "C:\Users\Dédé\Desktop\Text\"
nomfich = ThisWorkbook.Sheets(1).[K1]
formatfich = xlWorkbookNormal
If Val(Application.Version) >= 12 Then _
formatfich = IIf(ext = ".xls", 56, IIf(ext = ".xlsm", 52, 51))
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).Copy
With ActiveWorkbook
  ThisWorkbook.Sheets(2).Copy After:=.Sheets(1)



For Each o In .Sheets(1).DrawingObjects
    If Left(o.Name, 3) <> "SP-" And Left(o.Name, 4) <> "dudu" Then o.Delete 
  Next



  
  .Sheets(1).Activate
  On Error Resume Next 'si nomfich n'est pas autorisé
  .SaveAs chemin & nomfich, formatfich
  .Close False
End With

BONNE SOIREE