Autres Problème de macro

Bonjour,

Peut-être pourrais-tu poster ton fichier, vidé de toutes données personnelles.

Bonjour,
Je ne peux pas poster le fichier car il contient déjà beaucoup de données personnelles et lorsque j'essaie de les supprimer, je ne peux pas enregistrer le fichier à cause de l'erreur mentionnée dans le titre.

Bonjour @BDMNLLL47 et bienvenu sur XLD

BDMNLLL47 à dit:

Je ne peux pas poster le fichier car il contient déjà beaucoup de données personnelles

Cliquez pour agrandir...

Donc il faut répondre au pif alors au pif cela viens d'ici à remplacer par la bas !!

Est ce que cela t'aide ???
Pas sur du tout
Peut pas mieux faire en l'état avec si peux c'est à dire avec rien !!!

Phil69970 à dit:

Bonjour @BDMNLLL47 et bienvenu sur XLD


Donc il faut répondre au pif alors au pif cela viens d'ici à remplacer par la bas !!

Est ce que cela t'aide ???
Pas sur du tout
Peut pas mieux faire en l'état avec si peux c'est à dire avec rien !!!

Cliquez pour agrandir...

Bonjour Phil69970,
Inutile de vous montrer condescendant, je me rends bien compte que personne ne peut me debugger à l'aveugle.
Je demandais seulement s'il y avait moyen que je puisse identifier la ligne de code défaillante, par exemple en exécutant le code pas à pas.

@BDMNLLL47

je ne suis pas condescendant comme tu le dit j'essaye juste de te montrer qu'avec aucune information il est impossible de pouvoir t'aider.

Et pour ceci :

BDMNLLL47 à dit:

Je ne peux pas poster le fichier car il contient déjà beaucoup de données personnelles

Cliquez pour agrandir...

Tu peux faire cela :

Rien ne t’empêche de fournir un fichier représentatif

C'est quoi représentatif ?

- représentatif, même organisation des lignes et des colonnes, mêmes libellés, même nom des TS, mêmes noms de feuilles...
- anonymisé, pas de données personnelles réelles tels nom, n° sécu, adresse ... remplacé par Nom1, Nom2 etc ....
- simplifié, une quinzaine de lignes reproduisant l'ensemble des différents cas envisageables (Avec le résultat souhaité éventuellement)

Si sur la réponse fourni en retour cela fonctionne et pas sur le vrai fichier c'est qu'il n'est en rien représentatif ou que tu n'as pas su transposer ce qui devrait être un simple copier coller du code.

Bonsoir @BDMNLLL47

BDMNLLL47 à dit:

Bonjour Phil69970,
Inutile de vous montrer condescendant, je me rends bien compte que personne ne peut me debugger à l'aveugle.
Je demandais seulement s'il y avait moyen que je puisse identifier la ligne de code défaillante, par exemple en exécutant le code pas à pas.

Cliquez pour agrandir...

Bonsoir tout le monde,
Un petit tuto sur le pas à pas, si cela peut vous être utile.

BDMNLLL47 à dit:

Je demandais seulement s'il y avait moyen que je puisse identifier la ligne de code défaillante, par exemple en exécutant le code pas à pas.

Cliquez pour agrandir...

C'est la ligne qui apparait surlignée en jaune.

Bonjour,
Apparemment la ligne défaillante est celle-ci
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Ca, c'est le "titre" de la macro.
Est-ce qu'il y a un appel à cette macro dans le code du classeur ???

Voila tout le code que j'ai :

Private Sub Worksheet_Activate()
Range("A13") = "" 'enlève la mention "maj nécessaire"

'Repère pour bypasser l'Activate si une suppression d'agent est en cours
If Sheets(1).Range("A14") = 1 Then Exit Sub

DerLigne = Range("B11") + 13
For L = 14 To DerLigne
If Not Cells(L, 2) = "Nouveau" Then
'MAJ commentaires 1
SoldeHebdo = Cells(L, 31)
If Left(SoldeHebdo, 1) = "-" Then
Cells(L, 33) = "Vous avez affecté" & Chr(10) & "trop de service hebdo"
Else
If SoldeHebdo > 0.0001 Then
Cells(L, 33) = "Vous pouvez encore" & Chr(10) & "affecter du service"
Else
Cells(L, 33) = "Vous avez affecté" & Chr(10) & "tout le service prévu "
End If
End If
'MAJ commentaires 2
If Not Cells(L, 2) = "Nouveau" Then
Agent = Cells(L, 2)
Cells(L, 35) = Sheets(Agent).Cells(12, 1)
Cells(L, 36) = Sheets(Agent).Cells(15, 1)
If Left(Sheets(Agent).Cells(15, 1), 1) = "-" Then
Cells(L, 37) = "Trop d'heures ont été faites"
Else
If Sheets(Agent).Cells(15, 1) > 0.0001 Then
Cells(L, 37) = "Heures à faire avant la fin du contrat"
Else
Cells(L, 37) = "Le nombre d'heures prévues a été fait"
End If
End If
End If
End If
Next L

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False


If Range("A14") = 1 Then Exit Sub 'repère indiquant qu'une création ou une suppression d'agent est en cours

'met la couleur choisie par l'utilisateur sur la ligne précédemment choisie
If Range("A13") = "maj necessaire" And Ligne > 13 Then
Range(Cells(Ligne, 2), Cells(Ligne, 6)).Interior.ColorIndex = Cells(Ligne, 4).Interior.ColorIndex
Range(Cells(Ligne, 2), Cells(Ligne, 6)).Font.Color = Cells(Ligne, 4).Font.Color
End If

'Mise à jour commentaire solde hebdo si la colonne 6 vient d'être sélectionnée
If Colonne = 6 Then
SoldeHebdo = Cells(Ligne, 31)
If Left(SoldeHebdo, 1) = "-" Then
Cells(Ligne, 33) = "Vous avez affecté" & Chr(10) & "trop de service hebdo"
Else
If SoldeHebdo > 0.0001 Then
Cells(Ligne, 33) = "Vous pouvez encore" & Chr(10) & "affecter du service"
Else
Cells(Ligne, 33) = "Vous avez affecté" & Chr(10) & "tout le service prévu "
End If
End If
End If

'Mise à jour commentaire et solde global si la colonne 3 vient d'être sélectionnée
If Colonne = 3 Then
Sheets("IMPRESSIONS").Select
Sheets("EQUIPE").Select
Application.ScreenUpdating = True
End If


Ligne = ActiveCell.Row
Colonne = ActiveCell.Column
DerLigne = 13 + Sheets(1).Range("B11").Value

'replace le curseur en A12 pour protéger les cellules sensibles
If Application.Intersect(Target, Range("F2:F7,G7:AA9,G12:AA12,B14:F" & DerLigne)) Is Nothing Then Range("A12").Select

'Sur selection colonne 6 HHebdo, prépare la mise à jour la zone commentaires 1 et déclenche la màj par selection de la cellule adjacente (ce qui relance le SelectionChange)
If Not Application.Intersect(Target, Range(Cells(14, 6), Cells(DerLigne, 6))) Is Nothing Then
HHebdo = InputBox("Saisissez l'horaire hebdomadaire au format hh:mm", "Horaire Hebdo")
If InStr(HHebdo, ":") = 0 And Not HHebdo = "" Then
MsgBox "Merci de saisir une valeur en respectant le format hh:mm"
Cells(Ligne, 6) = "00:00"
Cells(Ligne, 5).Select
Else
If Not HHebdo = "" Then
Cells(Ligne, 6) = HHebdo
Cells(Ligne, 5).Select
Else
Cells(Ligne, 5).Select
End If
End If
End If

'Permet d'allumer ou d'éteindre les lunes dans le tableau "graduation" du panneau EQUIPE
If Not Application.Intersect(Target, Range("H8,K8,N8,Q8,T8,W8,Z8")) Is Nothing Then If ActiveCell.Value = "à" Then ActiveCell.Value = "" Else: ActiveCell.Value = "à"

'Permet de masquer/afficher des panneaux JOUR et d'éteindre/allumer les colonnes correspondantes dans EQUIPE
Application.ScreenUpdating = False
If Not Application.Intersect(Target, Range("G7,I7,L7,O7,R7,U7,X7,G12,I12,L12,O12,R12,U12,X12")) Is Nothing Then
'Repérage Panneau JOUR à masquer/afficher
Col = ActiveCell.Column
If Col = 7 Then Feuil = 3 Else: Feuil = Col / 3 + 1
'Execution
If ActiveCell.Font.ColorIndex = 2 Then
'Eteindre et masquer
Range(Cells(7, ActiveCell.Column), Cells(12, ActiveCell.Column)).Font.ColorIndex = 56
If ActiveCell = "D" Then Range(Cells(8, ActiveCell.Column), Cells(9, ActiveCell.Column)).Font.ColorIndex = 48 Else Range(Cells(8, ActiveCell.Column + 1), Cells(9, ActiveCell.Column + 1)).Font.ColorIndex = 48
Sheets(Feuil).Visible = False
Cells(11, 7).Font.ColorIndex = 2
Else
'Allumer et afficher
Cells(7, ActiveCell.Column).Font.ColorIndex = 2
Cells(12, ActiveCell.Column).Font.ColorIndex = 2
If ActiveCell = "D" Then Range(Cells(8, ActiveCell.Column), Cells(9, ActiveCell.Column)).Font.ColorIndex = 1 Else Range(Cells(8, ActiveCell.Column + 1), Cells(9, ActiveCell.Column + 1)).Font.ColorIndex = 1
Sheets(Feuil).Visible = True
Sheets(Feuil).Range("A8") = ""
End If
End If

'tableau graduation : si case vide alors inscription d'une valeur par défaut, sinon bug
If Range("G8") = "" Then Range("G8") = "14:00"
If Range("J8") = "" Then Range("J8") = "8:00"
If Range("M8") = "" Then Range("M8") = "8:00"
If Range("P8") = "" Then Range("P8") = "8:00"
If Range("S8") = "" Then Range("S8") = "8:00"
If Range("V8") = "" Then Range("V8") = "8:00"
If Range("Y8") = "" Then Range("Y8") = "8:00"
If Range("G9") = "" Then Range("G9") = "18:00"
If Range("J9") = "" Then Range("J9") = "18:00"
If Range("M9") = "" Then Range("M9") = "18:00"
If Range("P9") = "" Then Range("P9") = "18:00"
If Range("S9") = "" Then Range("S9") = "18:00"
If Range("V9") = "" Then Range("V9") = "18:00"
If Range("Y9") = "" Then Range("Y9") = "18:00"
Application.ScreenUpdating = False

'Détecte si la colonne 4 a été sélectionnée (colonne % / Couleur)
If Not Application.Intersect(Target, Columns(4)) Is Nothing And Ligne > 13 Then
Cells(13, 1) = "maj necessaire" 'programmation d'une mise à jour des couleurs partout lors du deactivate
End If

'Détecte si la colonne 2 a été sélectionnée
If Not Application.Intersect(Target, Columns(2)) Is Nothing And Not Ligne = 12 Then
Cells(13, 1) = "maj necessaire": Nom = ActiveCell.Value 'programmation d'une mise à jour des noms partout lors du deactivate
If Nom = "Nouveau" Then 'Création nouveau calendrier
Agent = InputBox("Donnez ci-dessous un nom à ce nouvel agent :", "Nommer un agent")
If Not Agent = "" Then
If Not Agent Like "*[?]*" And Not Agent Like "*[:]*" And Not Agent Like "*[/]*" And Not Agent Like "*[\]*" And Not Agent Like "*[*]*" And Not Agent Like "*[[]*" And Not Agent Like "*[]]*" And Not Agent = "Nouveau" And Not IsNumeric(Agent) Then
ActiveCell.Value = Agent
Sheets("CALENDRIER").Copy After:=Sheets(Sheets.Count)
Sheets("CALENDRIER (2)").Name = Agent
MsgBox ("Le calendrier de " & Agent & " vient d'être crée.")
Sheets(1).Select
Else
Select Case Agent
Case "Nouveau": MsgBox "Le nom de votre agent ne peut pas être 'Nouveau'. Merci de recommencer"
Case IsNumeric(Agent): MsgBox " Le nom de votre agent ne peut pas être exclusivement un chiffre ou un nombre. Ajoutez au moins une lettre. Merci de recommencer"
Case Else: MsgBox "Le nom de votre agent ne doit pas comporter les caractères suivants :" & Chr(10) & " ? * / \ : [ ]" & Chr(10) & "Merci de recommencer"
End Select
End If
End If
Else
If MsgBox("Voulez-vous modifier le nom de cet agent ?", vbYesNo, "Attention") = vbYes Then
Agent = InputBox("Modifiez ci-dessous le nom de cet agent :", "Nommer un agent")
If Not Agent Like "*[?]*" And Not Agent Like "*[:]*" And Not Agent Like "*[/]*" And Not Agent Like "*[\]*" And Not Agent Like "*[*]*" And Not Agent Like "*[[]*" And Not Agent Like "*[]]*" And Not Agent = "Nouveau" And Not IsNumeric(Agent) Then
If Not Agent = "" Then
ActiveCell.Value = Agent
'1er cas : on change le nom et on ne veut pas garder le calendrier de l'ancien nom, juste en crée un nouveau (c'est le cas lorsqu'on change d'année scolaire par exemple ou suite à une démission)
If MsgBox("Voulez-vous supprimer le calendrier de " & Nom & " ? Cliquez sur OUI pour le supprimer. Cliquez sur NON pour que le nom du calendrier soit juste modifié.", vbYesNo, "Suppression ou modification du calendrier ?") = vbYes Then
Application.DisplayAlerts = False
Sheets(Nom).Delete
Application.DisplayAlerts = True
MsgBox "Le calendrier de " & Nom & " vient d'être supprimé." 'suppression du calendrier de l'ancien nom
Sheets("CALENDRIER").Copy After:=Sheets(Sheets.Count)
Sheets("CALENDRIER (2)").Name = Agent
MsgBox ("Le calendrier de " & Agent & " vient d'être crée.") 'création du calendrier du nouveau nom
Sheets(1).Select
Cells(Ligne, 3) = 0
Cells(Ligne, 4).Select
'2eme cas : on veut juste modifier le nom du calendrier (par exemple parce qu'on a fait une faute d'orthographe dans le nom)
Else
Sheets(Nom).Name = Agent
MsgBox ("Le nom du calendrier de " & Nom & " vient d'être modifié. Il est maintenant intitulé " & Agent)
End If
End If
Else
Select Case Agent
Case "Nouveau": MsgBox "Le nom de votre agent ne peut pas être 'Nouveau'. Merci de recommencer"
Case IsNumeric(Agent): MsgBox " Le nom de votre agent ne peut pas être exclusivement un chiffre ou un nombre. Ajoutez au moins une lettre. Merci de recommencer"
Case Else: MsgBox "Le nom de votre agent ne doit pas comporter les caractères suivants :" & Chr(10) & " ? * / \ : [ ]" & Chr(10) & "Merci de recommencer"
End Select
End If
End If
End If
Cells(Ligne, 4).Select
End If

'Sur selection colonne 3 HContrat, mise à jour des compteurs dans le calendrier de l'agent concerné
If Not Application.Intersect(Target, Range(Cells(14, 3), Cells(DerLigne, 3))) Is Nothing Then
If Not Cells(Ligne, 2) = "Nouveau" Then
Nom = Cells(Ligne, 2).Value
AncienneValeur = Cells(Ligne, 3)
HContrat = InputBox("Indiquez ci-dessous le volume horaire total de son contrat (exemple : 1607)", "Volume horaire du contrat")
If Not IsNumeric(HContrat) Then HContrat = 0: MsgBox "Indiquez juste un nombre, sans ponctuation ni lettre (exemple : 1607)": Cells(Ligne, 4).Select: Exit Sub
If Not HContrat = "" Or HContrat = 0 Then
Cells(Ligne, 3) = HContrat
Sheets(Nom).Cells(9, 1) = HContrat & ":00"
Else
Cells(Ligne, 3) = AncienneValeur
End If
Cells(Ligne, 4).Select
Else
MsgBox "Pour changer cette valeur vous devez d'abord nommer cet agent"
Cells(Ligne, 4).Select
End If
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Ligne = ActiveCell.Row
DerLigne = 14 + Range("B11").Value
Agent = Cells(Ligne, 2)
HContrat = Cells(Ligne, 3)
Quotité = Cells(Ligne, 4)
Cancel = True
If Ligne > 13 And Ligne < DerLigne Then
If MsgBox("Voulez-vous afficher le calendrier de " & Cells(Ligne, 2) & " ?", vbYesNo, "Ouvrir un calendrier ?") = vbYes Then
If Agent = "Nouveau" Then MsgBox "Pas de calendrier pour Nouveau": Cells(12, 1).Select: Exit Sub
Sheets(Agent).Visible = True
Sheets(Agent).Select
Sheets(Agent).Cells(2, 1) = Ligne
Sheets(Agent).Cells(25, 1) = "EQUIPE"
Sheets(Agent).Cells(1, 2) = Agent & " : " & Quotité & " %"
Sheets(Agent).Cells(38, 2) = Sheets(Agent).Cells(1, 2)
Sheets(Agent).Cells(9, 1) = HContrat & ":00"
Sheets(Agent).Cells(12, 1) = Sheets(Agent).Cells(36, 4) + Sheets(Agent).Cells(36, 9) + Sheets(Agent).Cells(36, 14) + Sheets(Agent).Cells(36, 19) + Sheets(Agent).Cells(36, 24) + Sheets(Agent).Cells(36, 29) + Sheets(Agent).Cells(72, 4) + Sheets(Agent).Cells(72, 9) + Sheets(Agent).Cells(72, 14) + Sheets(Agent).Cells(72, 19) + Sheets(Agent).Cells(72, 24) + Sheets(Agent).Cells(72, 29)
If Left(Sheets(Agent).Cells(15, 1), 1) = "-" Then
Sheets(Agent).Cells(16, 1) = "Trop d'heures ont été faites"
Else
If Sheets(Agent).Cells(15, 1) > 0.0001 Then
Sheets(Agent).Cells(16, 1) = "Ces heures sont à faire avant la fin du contrat"
Else
Sheets(Agent).Cells(16, 1) = "Le nombre d'heures prévues a été fait"
End If
End If
Else
Cells(12, 1).Select
End If
End If
End Sub
Private Sub Worksheet_Deactivate()
'Permet la mise à jour des noms (couleur fond et police aussi) dans les panneaux JOUR, EDT SEMAINE et IMPRESSIONS
If Colonne = 4 And Ligne > 13 Then
Sheets(1).Cells(13, 1) = "maj necessaire"
With Range(Cells(Ligne, 2), Cells(Ligne, 6))
.Interior.ColorIndex = Sheets(1).Cells(Ligne, 4).Interior.ColorIndex
.Font.Color = Sheets(1).Cells(Ligne, 4).Font.Color
.Font.Bold = True
End With
End If

If Sheets(1).Cells(13, 1) = "maj necessaire" Then
DerLigne = 13 + Sheets(1).Range("B11").Value

'Panneaux JOUR
For IndiceFeuille = 3 To 9
For L = 14 To DerLigne
With Sheets(IndiceFeuille).Cells(L, 7)
.Value = Sheets(1).Cells(L, 2).Value
.Interior.ColorIndex = Sheets(1).Cells(L, 4).Interior.ColorIndex
.Font.Color = Sheets(1).Cells(L, 4).Font.Color
.Font.Bold = True
End With
Next L
Next IndiceFeuille

'Panneaux EDT SEMAINE
For L = 14 To DerLigne
With Sheets("EDT SEMAINE").Cells(L, 2)
.Value = Sheets(1).Cells(L, 2).Value
.Interior.ColorIndex = Sheets(1).Cells(L, 4).Interior.ColorIndex
.Font.Color = Sheets(1).Cells(L, 4).Font.Color
.Font.Bold = True
End With
Next L


'Panneau IMPRESSIONS
For L = 14 To DerLigne
With Sheets("IMPRESSIONS").Cells(L, 3)
.Value = Sheets(1).Cells(L, 2).Value
.Interior.ColorIndex = Sheets(1).Cells(L, 4).Interior.ColorIndex
.Font.Color = Sheets(1).Cells(L, 4).Font.Color
.Font.Bold = True
End With
With Sheets("IMPRESSIONS").Cells(L, 6)
.Value = Sheets(1).Cells(L, 2).Value
.Interior.ColorIndex = Sheets(1).Cells(L, 4).Interior.ColorIndex
.Font.Color = Sheets(1).Cells(L, 4).Font.Color
.Font.Bold = True
End With
Next L

End If
End Sub

BDMNLLL47 à dit:

Voila tout le code que j'ai

Cliquez pour agrandir...

Il n'y a même pas la macro sur laquelle tu dis que ça plante...

J'ai réussi à sauvegarder le fichier en supprimant les noms des personnes concernées.
Je le mets en pièce jointe.

Excel ne veut même pas enregistrer le classeur car il est complètement vérolé et impossible à réparer.