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

Bonjour Pierrot

J'ai trouvé un code sur le net qui fonctionne pas trop mal sauf que je ne peut qu'enregistrer la feuille active
n'ayant plus de nouvelle de toi j'ai posté une nouvelle demande mon code est:

Sub Archiver()

Dim extension As String
Dim chemin As String, nomfichier As String
Dim style As Integer
Application.ScreenUpdating = False
ThisWorkbook.ActiveSheet.Copy
extension = ".xlsm"
chemin = "C:\Users\Max\Desktop\Test\"
nomfichier = ActiveSheet.Range("A1") ' & extension
With ActiveWorkbook
      .ActiveSheet.DrawingObjects(2).Delete
    .SaveAs Filename:=chemin & nomfichier
    .Close
End With
End Sub

Si tu peut regarde s'il on peut modifier

Bonne journée

 

[Pierrot93]

Re : Enregistrer deux onglets sur dix

Re,

tu as vu le post #15 ?

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

Oui c'est bon petit souci le chemin via l'enregistrement
j'ai rajouté a ton code

Dim Chemin As String

Chemin = "C:\Users\Max\Desktop\Test\"

Sa ne fonctionne pas?

 

[Pierrot93]

Re : Enregistrer deux onglets sur dix

Re,

avec le chemin :

Option Explicit
Sub test()
Dim i As Integer, x As String, Chemin As String
Workbooks("Matrise.xlsm").Save
Application.DisplayAlerts = False
For i = 10 To 3 Step -1
     Sheets(i).Delete
     Next i
Application.DisplayAlerts = True
x = InputBox("Nom fichier ?")
Chemin = "C:\Users\Max\Desktop\Test\"
If x <> "" Then ActiveWorkbook.SaveAs Chemin & x
End Sub

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

Nickel je te remercie beaucoup
question pourquoi le fichier nommer se ferme et que le fichier enregistrer reste ouvert?

Merci encore

 

[Pierrot93]

Re : Enregistrer deux onglets sur dix

Re,

question pourquoi le fichier nommer se ferme et que le fichier enregistrer reste ouvert?

il ne se ferme pas, mais le fait de faire un "enregistrer sous" en créé un autre en fait... c'est pourquoi le "save" de "Matrise.xlsm" pour ne pas perdre les modifs du fichier original...

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

Ok compris je te remercie beaucoup et te souhaite une bonne journée

 

[job75]

Re : Enregistrer deux onglets sur dix

Bonjour maval, Pierrot, le forum,

Pour compléter la macro du post #16 :

Sub Archiver()
Dim ext$, chemin$, nomfich$, formatfich
ext = ".xlsm" '.xlsx '.xls 'à adapter
chemin = ThisWorkbook.Path & "\" '"C:\Users\Max\Desktop\Test\"
nomfich = ThisWorkbook.Sheets(1).[A1]
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)
  On Error Resume Next 'si nomfich n'est pas autorisé
  .Sheets(1).DrawingObjects(2).Delete '??
  .SaveAs chemin & nomfich, formatfich
  .Close False
End With
End Sub

L'extension, donc le format du fichier, est paramétrable.

Bonne journée.

 

[maval]

Re : Enregistrer deux onglets sur dix

Bonjour Job75,

Je te remercie beaucoup peut tu me dire comment supprimer tous les bottons se trouvant sur la première feuille sauf un nommer "dudu"

merci et bonne journée

 

[job75]

Re : Enregistrer deux onglets sur dix

Re,

Je crois que le format xlWorkbookDefault n'est valable qu'à partir d'Excel 2007, je l'ai donc remplacé par xlWorkbookNormal.

Pour supprimer les objets sauf un il suffit d'une boucle :

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).[A1]
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 o.Name <> "dudu" Then o.Delete
  Next
  On Error Resume Next 'si nomfich n'est pas autorisé
  .Sheets(1).DrawingObjects(2).Delete '??
  .SaveAs chemin & nomfich, formatfich
  .Close False
End With
End Sub

Edit : si l'on veut aussi supprimer les contrôles ActiveX remplacer .DrawingObjects par .Shapes

A+

 

[DoubleZero]

Re : Enregistrer deux onglets sur dix

Bonjour, Pierrot , Job75 , re-bonjour, maval,

... peut tu me dire comment supprimer tous les bottons se trouvant sur la première feuille sauf un nommer "dudu"...

Deux tentatives ici !

A bientôt

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

Je te remercie seul petit souci est que sa me supprime bien les boutons mais en plus les schappes?

@+

 

[job75]

Re : Enregistrer deux onglets sur dix

Re,

Juste pour dire bonjour à notre chère ânesse

Et pour rappeler mon post #25 qui n'a pas été vu

A+

 

[maval]

Re : Enregistrer deux onglets sur dix

Re,

J'ai bien changer DrawingObjects par .Shapes sa me supprime toujours toute les shapes alors que j'aimerais qu'il me suppriome que les boutons du contrôle de formulaire

@+

 

[job75]

Re : Enregistrer deux onglets sur dix

Re,

Effectivement DrawingObjects inclut les OLEObjects donc utilisez cette macro :

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).[A1]
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 TypeName(o) <> "OLEObject" And o.Name <> "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
End Sub

A+