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