Simplifié une macro

[wachoo31]

Bonjour à toutes et tous

Mon problème est que a l'aide de ce forum, j'ai créé une macro qui fonctionne correctement mais qui je le sais est mal concue, mais voilà je n'arrive pas a la simplifié.
De plus comment faire la même macro pour la copie de plusieurs feuilles


#
Sub Sauvegarde_Appointement()
Dim Chemin As String
Dim Question As String
Dim newbook As Workbook

Chemin = ThisWorkbook.Path & "\Sauvegarde des calculs\"
If Dir(Chemin, vbDirectory) > "" Then

Question = Sheets("App.").Range("c13") & " " & Range("c14") & " " & Format(Date, "dd.mm.yyyy")

Application.ScreenUpdating = False

Sheets("Print App.").Activate
Sheets("Print App.").Visible = -1
Sheets("Print App.").Copy
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Cells.Validation.Delete

With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With

With ActiveWorkbook
.SaveAs Chemin & Question & ".xls"
.Close '<<< supprimer si on veut garder le classeur à l'écran
End With
Sheets("Print App.").Visible = 2
Sheets("App.").Select
Application.ScreenUpdating = True
Exit Sub
Else
MsgBox "Ce dossier n'existe pas"
MkDir ThisWorkbook.Path & "\Sauvegarde des calculs\"

End If
Question = Sheets("App.").Range("c13") & " " & Range("c14") & " " & Format(Date, "dd.mm.yyyy")

Application.ScreenUpdating = False

Sheets("Print App.").Activate
Sheets("Print App.").Visible = -1
Sheets("Print App.").Copy
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Cells.Validation.Delete

With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With

With ActiveWorkbook
.SaveAs Chemin & Question & ".xls"
.Close '<<< supprimer si on veut garder le classeur à l'écran
End With
Sheets("Print App.").Visible = 2
Sheets("App.").Select
Application.ScreenUpdating = True

End Sub

 

[wachoo31]

Re : Simplifié une macro

Re, juste pour remonter mon problème
Merci

 

[GCFRG]

Re : Simplifié une macro

salurt wachoo, peut être avec un bout de ton fichier
on pourras tester !!

Gilbert

 

[XL_Luc]

Re : Simplifié une macro

Mais elle est pas mal du tout, juste une petite "erreur" enfin je crois.
Ta macro est presque doublée en taille, tu finis le if par un exit sub et tu recommence strictement la même procédure si tu crés le répertoire.
Je ferai donc (non testé donc il peut y avoir des erreurs)

Sub Sauvegarde_Appointement()
Dim Chemin As String
Dim Question As String
Dim newbook As Workbook

Chemin = ThisWorkbook.Path & "\Sauvegarde des calculs\"
If Dir(Chemin, vbDirectory) = "" Then
'XLLuc on crée d'abord le répertoire si necessaire
MsgBox "Ce dossier n'existe pas"
MkDir ThisWorkbook.Path & "\Sauvegarde des calculs\"
End If

Question = Sheets("App.").Range("c13") & " " & Range("c14") & " " & Format(Date, "dd.mm.yyyy")

Application.ScreenUpdating = False

Sheets("Print App.").Activate
Sheets("Print App.").Visible = -1
'Sheets("Print App.").Copy --> XlLuc pourquoi copier alors qeue tu fait un cells.copy après
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Cells.Validation.Delete

With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With

With ActiveWorkbook
.SaveAs Chemin & Question & ".xls"
.Close '<<< supprimer si on veut garder le classeur à l'écran
End With
Sheets("Print App.").Visible = 2
Sheets("App.").Select
'Application.ScreenUpdating = True --> XLluc : inutile si une autre macro n'est pas lancée à la suite, c'est implicite à la fin des procédure

End Sub

 

[wachoo31]

Re : Simplifié une macro

Bonjour XL_Luc

Merci à toi pour la simplification effectuée, cela est beaucoup plus conventionnelle et cela marche à merveille.
Si je peu demander:
Avec une copie semblable à cette macro comment doit-je faire pour copier à la place de la feuille "sheets("App.") plusieurs feuilles du genre sheets("Cal.App.") + sheets("rev.sal.") + sheets("program.") ?

 

[XL_Luc]

Re : Simplifié une macro

J'éteins mon PC pour 1 semaine, je laisse le soin au forum de te répondre