Beug avec ActiveWorkbook.Save dans un module
Bonjour,
Cette macro est lancée avec Private Sub Workbook_BeforeSave et fonctionne parfaitement bien avec le raccourcis clavier CTRL+S et avec le clic sur la disquette Enregistrer de la barre d'outils Excel.
Cependant impossible de la lancer la macro via ActiveWorkbook.Save, la feuille Interventions ne se copie pas.
J'ai essayé de déplacer ActiveWorkbook.Save dans une feuille, puis une autre feuille, dans ThisWorkbook, mais rien ne change.
C'est comme si la macro ne reconnaissait pas le classeur et ne trouvait pas les feuilles, car si la feuille planning existe elle n'est pas supprimée au départ de la macro …
C'est étrange, quelqu'un a t'il déjà rencontré ce problème ?
Merci pour votre aide
Philippe
Code:
1
2
3
| Sub Bouton_Save()
ActiveWorkbook.Save
End Sub |
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
| Option Explicit
Dim chemin As String
Dim Nom_du_xlsx As String
Sub Copie_fichier_xlsx() 'Dans Workbook_BeforeSave
Dim Verification As Boolean
Dim MonClasseur As String
chemin = ThisWorkbook.Path & "\"
Nom_du_xlsx = "Copie du planning.xlsx"
'Mise à jour de la copie avec la Function EstClasseurOuvert(MonClasseur As String)
MonClasseur = chemin & Nom_du_xlsx
'Vérifier si la copie existe
If Len(Dir(MonClasseur)) = 0 Then
'Si la copie n'existe pas, créer la copie
Copie_xlsx.Creation_Fichier_Planning_xlsx
Else
'Si la copie existe, vérifier si la copie est ouverte
Verification = EstClasseurOuvert(MonClasseur)
If Verification = True Then
'Si la copie est ouverte on informe et on quitte.
MsgBox "La copie du planning est ouverte, mise à jour impossible...", vbInformation, "Info"
Exit Sub
Else
'Si la copie est fermée
Copie_xlsx.Creation_Fichier_Planning_xlsx
End If
End If
End Sub
Function EstClasseurOuvert(MonClasseur As String)
'Pour vérifier si un classeur est ouvert
Dim NumeroFichier As Long, NumeroErreur As Long
On Error Resume Next
NumeroFichier = FreeFile()
Open MonClasseur For Input Lock Read As #NumeroFichier
Close NumeroFichier
NumeroErreur = Err
On Error GoTo 0
Select Case NumeroErreur
Case 0: EstClasseurOuvert = False
Case 70: EstClasseurOuvert = True
Case Else: Error NumeroErreur
End Select
End Function
Sub Creation_Fichier_Planning_xlsx() 'IMPORTANT !!! Lancer cette macro avec la macro "Copie_fichier_xlsx" pour vérifier avant si la copie est ouverte ou existe
Dim objWorkbookCible As Workbook
Dim objworkbooksource As Workbook
Dim ShProvisoire As Worksheet
Application.ScreenUpdating = False ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
Set objworkbooksource = ActiveWorkbook
'Suppression de l'onglet "Planning"
For Each ShProvisoire In Sheets
If ShProvisoire.Name = "Planning" Then
Application.DisplayAlerts = False 'Désactive la Msgbox Etes-vous sûr de vouloir supprimer l'onglet
ShProvisoire.Delete
Application.DisplayAlerts = True 'Réactive la Msgbox Etes-vous sûr de vouloir supprimer l'onglet
Exit For
End If
Next ShProvisoire
'Copier la feuille
Sheets("Interventions").Copy After:=Sheets(Sheets.Count)
'Renommer la feuille
Set ShProvisoire = ActiveSheet
ShProvisoire.Name = "Planning"
''Supprimer toutes les images de la feuille planning
' ActiveSheet.DrawingObjects.Delete
'Copier les feuilles
Sheets(Array("Planning", "DATA_Jours_Fériés")).Copy 'Copier DATA_Jours_Fériés pour colorer le planning
Set objWorkbookCible = ActiveWorkbook
'Supprimer toutes les images de la feuille DATA_Jours_Fériés
ActiveSheet.DrawingObjects.Delete
'Enregister le fichier
Sheets("Planning").Select
Application.DisplayAlerts = False 'Désactive la Msgbox Etes-vous sûr de vouloir
ActiveWorkbook.SaveAs chemin & Nom_du_xlsx, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True 'Réactive la Msgbox Etes-vous sûr de vouloir
ActiveWorkbook.Close
Set ShProvisoire = Nothing 'Cette commande sert à libérer l'espace mémoire réservée pour cette variable.
'Supprimer la feuille planning
Application.DisplayAlerts = False
Sheets("Planning").Delete
Application.DisplayAlerts = True
Sheets("Interventions").Select
Application.ScreenUpdating = True ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
End Sub |
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
| Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim CheminSource As String
Dim DossierBackup As String
Dim Nom As String
Dim NomMajuscule As String
'Créer une copie du fichier pour lecture
Copie_xlsx.Copie_fichier_xlsx
'Sauvegarde une copie du fichier nommé: Date & la date, dans un dossier, dans le même dossier du fichier, nommé: Backup & le nom du fichier
Nom = Environ("USERNAME")
NomMajuscule = UCase(Nom) 'UCase = Mise en majuscule - LCase = minuscule - Application.proper = Nom propre
DossierBackup = "Backup " & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) 'Pour enlever le .xlsm les 5 caractères depuis la droite
CheminSource = ThisWorkbook.Path & "\" & DossierBackup & "\"
'Test si le dossier existe déjà
On Error Resume Next 'N'éxécute pas la ligne qui suit en cas d'erreur
MkDir CheminSource
On Error GoTo 0 'Ressort de l'erreur qui permet de nouvelles erreurs
'Sauvegarde d'une copie du fichier avec la date
ActiveWorkbook.SaveCopyAs CheminSource & Format(Now(), "YYYY.MM.DD hh-mm-ss ") & NomMajuscule & " " & ThisWorkbook.Name
End Sub |
