Discussion :

[Hocked]

Bonsoir à tous,

J'ai un gros soucis avec mon code qui devrait normalement fonctionner; mais qui bloque Excel (Excel ne répond pas et se fige).

Pour vous exposer ma macro, celle-ci réalise un filtre spécifique sur une plage déterminée avec extraction dans un fichier PDF, puis envoie ce fichier par mail au destinataire et finit par retirer le filtrage alternatif pour retrouver la plage de données dans son état d'origine (avec filtre automatique).

Pour cela voici dans l'ordre mon code (assez long mais qui peut certainement être amélioré sans que je sache comment faire) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Sub EnvoiMailRelanceDateReal()
'Envoi du mail d'alerte pour dépassement de la date de fin d'intervention prévisionnel aux différents destinataires
On Error GoTo errorHandler
 
ActiveSheet.Unprotect ("CTM1410")
 
EnvoiMailRelanceDateRealCTM
 
Supprime_filtre_alternative
ShowAllData_fonctionne_a_priori_toujours
retablit_filtre_automatique
ActiveSheet.Protect Password:="CTM1410", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFiltering:=True
 
Kill ThisWorkbook.Path & "\" & "RelanceTravaux.pdf"
MsgBox "Les fichiers PDF correspondant ont été adressés aux différents destinataires !", vbInformation, "Félicitations !"
 
errorHandler:
            If Err.Number <> 0 Then
                MsgBox "EnvoiMailRelanceDateReal : Erreur n° " & Err.Number & " !" & vbCrLf & _
                "Merci de contacter votre administrateur !", vbCritical, "Attention !"
            End If
End Sub

Où EnvoiMailRelanceDateRealCTM équivaut à :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Sub EnvoiMailRelanceDateRealCTM()
'Envoi du mail d'alerte pour dépassement de la date de fin d'intervention prévisionnel au CTM
 
'Si une erreur survient, on va à la ligne "errorHandler"
On Error GoTo errorHandler
'On Error Resume Next
 
ActiveSheet.Unprotect ("CTM1410")
FiltreCTM
 
    Application.ScreenUpdating = False
    Sheets(Feuil2.Name).Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & "RelanceTravaux.pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
    Sheets(Feuil2.Name).Select
    Application.ScreenUpdating = True
 
EnvoiMailRelanceTvxCTM
 
ToutAfficher
 
ActiveSheet.Protect Password:="CTM1410", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFiltering:=True
Kill ThisWorkbook.Path & "\" & "RelanceTravaux.pdf"
 
errorHandler:
            If Err.Number <> 0 Then
                MsgBox "EnvoiMailRelanceDateRealCTM : Erreur n° " & Err.Number & " !" & vbCrLf & _
                "Merci de contacter votre administrateur !", vbCritical, "Attention !"
            End If
End Sub

Dont FiltreCTM égale à :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub FiltreCTM()
Dim NbLg As Long
On Error GoTo errorHandler
'On Error Resume Next
    ToutAfficher
    NbLg = Range("B3").End(xlDown).Row
    Range("A3:V" & NbLg).AutoFilter Field:=14, Criteria1:="=CTM" 'Tri sur destinataire = CTM
    Range("A3:V" & NbLg).AutoFilter Field:=13, Criteria1:="=" 'Tri sur date de réalisation non renseignée
    Range("A3:V" & NbLg).AutoFilter Field:=12, Criteria1:="<" & Format(Date, "mm/dd/yy") 'Tri sur date de fin d'exécution prévisionnelle dépassée
errorHandler:
            If Err.Number <> 0 Then
                MsgBox "FiltreCTM : Erreur n° " & Err.Number & " !" & vbCrLf & _
                "Merci de contacter votre administrateur !", vbCritical, "Attention !"
            End If
End Sub

Et dont EnvoiMailRelanceTvxCTM est :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub EnvoiMailRelanceTvxCTM()
 
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adresse As String
Dim message As String
Dim sujet As String
 
Dim i As Variant
Dim appOutlook As Outlook.Application
 
Dim TCD As Range, Cel As Range
Dim Plage As Range
Dim Var As String
 
'Si une erreur survient, on va à la ligne "errorHandler"
On Error GoTo errorHandler
 
 
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    Set TCD = Range("A3:V" & Range("A1500").End(xlUp).Row)
    TCD.AutoFilter Field:=14, Criteria1:="=CTM" 'Tri sur destinataire = CTM
    TCD.AutoFilter Field:=13, Criteria1:="=" 'Tri sur date de réalisation non renseignée
    TCD.AutoFilter Field:=12, Criteria1:="<" & Format(Date, "mm/dd/yyyy") 'Tri sur date de fin d'exécution prévisionnelle dépassée
 
    Set Plage = Range("a3:a" & Range("a1500").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
 
MsgBox "CTM : " & (Application.Subtotal(3, ActiveSheet.Range("A:A")) - 3)
If (Application.Subtotal(3, ActiveSheet.Range("A:A")) - 3) = 0 Then
'rien
Else
ActiveSheet.Unprotect ("CTM1410")
    For Each Cel In Plage
        Cells(Cel.Row, "u") = Format(Now(), "dd/mm/yyyy")
        Var = Cells(Cel.Row, "o")
    Next Cel
 
 
Set appOutlook = CreateObject("Outlook.Application")
 
    If Not (appOutlook Is Nothing) Then
 
    sujet = "URGENT - RELANCE : dates prévisionnelles d'interventions dépassées !" 'Définition du sujet du mail
    adresse = Var 'Recherche l'adresse mail du destinataire
    'MsgBox "adresse mail : " & adresse
 
    'Définition du message
    message = "Bonjour, " & vbCrLf & vbCrLf & _
        "Nous vous informons que les délais d'exécution prévisionnels communiqués concernant les demandes de travaux figurant dans le document ci-joint sont dépassés. " & vbCrLf & _
        vbCrLf & "Merci de bien vouloir faire le nécessaire afin de régulariser ces demandes au plus vite et" & _
        " également informer les services demandeur des raisons de ce retard et des nouveaux délais d'exécution." & vbCrLf & _
        "Si les interventions ont été effectuées et qu'il s'agit d'un oubli de transmission, merci de bien vouloir nous retourner rapidement" & _
        " les fiches 'bon de travaux' correspondantes dûment renseignées afin de clôturer les demandes concernées." & vbCrLf & vbCrLf & _
        "Dans l'attente de vous lire," & vbCrLf & vbCrLf & _
        "Bien cordialement," & vbCrLf & vbCrLf & _
        "Le sécrétariat."
 
    'Paramètres de l'application mail
    Set OutlookApp = CreateObject("outlook.application")
    Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
            .Subject = sujet
            .To = adresse
            .Attachments.Add (ThisWorkbook.Path & "\" & "RelanceTravaux.pdf")
            .body = message
            .send 'Envoi du mail
            End With
    End If
End If
 
errorHandler:
            If Err.Number > 0 Then
                MsgBox "Envoi msg CTM : " & Err.Number
                MsgBox "Envoi mail au CTM : impossible d'effectuer cette opération !" & vbCrLf & "Merci de vérifier que Microsoft Outlook est bien ouvert !" & vbCrLf & _
                "Aucun mail n'a été envoyé !", vbCritical, "Attention !"
            End If
 
End Sub

Et ToutAfficher :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub ToutAfficher()
On Error GoTo errorHandler
'On Error Resume Next
'If ActiveSheet.Protect = True Then ActiveSheet.Unprotect ("CTM1410")
If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
errorHandler:
            If Err.Number <> 0 Then
                MsgBox "ToutAfficher : Erreur n° " & Err.Number & " !" & vbCrLf & _
                "Merci de contacter votre administrateur !", vbCritical, "Attention !"""
            End If
End Sub

+ Supprime_filtre_alternative :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub Supprime_filtre_alternative()
On Error Resume Next
If ActiveSheet.Protect = True Then ActiveSheet.Unprotect ("CTM1410")
Feuil2.Select
Range("A1").Select
If Feuil2.FilterMode Then
Feuil2.UsedRange.AutoFilter
Feuil2.UsedRange.AutoFilter
End If
End Sub

Puis ShowAllData_fonctionne_a_priori_toujours :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub ShowAllData_fonctionne_a_priori_toujours()
On Error Resume Next
If ActiveSheet.Protect = True Then ActiveSheet.Unprotect ("CTM1410")
Feuil2.Select
Range("A1").Select
If Feuil2.FilterMode Then
Feuil2.ShowAllData
End If
End Sub

Ainsi que retablit_filtre_automatique :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Sub retablit_filtre_automatique()
On Error Resume Next
If ActiveSheet.Protect = True Then ActiveSheet.Unprotect ("CTM1410")
Feuil2.Select
Range("A1").Select
If Not ActiveSheet.AutoFilterMode Then ActiveSheet.Range("A2").AutoFilter
End Sub

Voilà c'est tout ! En espérant avoir été suffisamment explicite.

Je sais c'est un peu long; mais si vous aviez la grandeur de bien vouloir vous pencher sur mon code et me dire où cela peut coincer pour en arriver à planter Excel, je vous en serez éternellement reconnaissant.

Merci d'avance de votre aide.

Cordialement.

[Hocked]

Bonjour à tous,

Après avoir revu l'ensemble de mon code, j'ai réussi à le simplifier et cela fonctionne maintenant.

Pour ceux que cela intéresserait, je vous le communique ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
Sub EnvoiMailRelanceDateReal()
 
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim fs As Object
Dim f As Object
Dim adresse As String
Dim message As String
Dim sujet As String
 
 
Dim appOutlook As Outlook.Application
 
Dim TCD As Range, Cel As Range
Dim Plage As Range
Dim Var As String
Dim NbLg As Long
Dim NbLigFiltre As String
Dim Desti As Variant
Dim RDest As Range
 
'Si une erreur survient, on va à la ligne "errorHandler"
On Error GoTo errorHandler
 
Set RDest = Sheets(Feuil1.Name).Range("I2:I8")
 
For Each Desti In RDest
 
'MsgBox "Destinataire : " & Desti
    NbLg = Range("B3").End(xlDown).Row
    Feuil2.Select
    ActiveSheet.Unprotect ("CTM1410")
    Range("A3:V" & NbLg).AutoFilter Field:=14, Criteria1:="=" & Desti 'Tri sur destinataire de la liste en colonne I de la feuille 1
    Range("A3:V" & NbLg).AutoFilter Field:=13, Criteria1:="=" 'Tri sur date de réalisation non renseignée
    Range("A3:V" & NbLg).AutoFilter Field:=12, Criteria1:="<" & Format(Date, "mm/dd/yy") 'Tri sur date de fin d'exécution prévisionnelle dépassée
'MsgBox Desti & " - 1 - Verif Filtre"
 
 
    Application.ScreenUpdating = False
    ActiveSheet.Select
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & "RelanceTravaux.pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
 
    ActiveSheet.Select
    Application.ScreenUpdating = True
'MsgBox Desti & " - 2 - Verif Sauvegarde Fichier"
 
Set Plage = Range("A3:A" & Range("A1500").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
NbLigFiltre = (Application.Subtotal(3, ActiveSheet.Range("A:A")) - 2)
'MsgBox Desti & " - Nombre de cellules sélectionnées : " & (Application.Subtotal(3, ActiveSheet.Range("A:A")) - 2)
 
If NbLigFiltre = 0 Then
GoTo Next_Desti
Else
ActiveSheet.Unprotect ("CTM1410")
    For Each Cel In Plage
        Cells(Cel.Row, "u") = Format(Now(), "dd/mm/yyyy")
        Var = Cells(Cel.Row, "o")
    Next Cel
'MsgBox Desti & " - 3 - Verif Renseignement Cellule Date"
 
Set appOutlook = CreateObject("Outlook.Application")
 
    If Not (appOutlook Is Nothing) Then
 
    sujet = "URGENT - RELANCE : dates prévisionnelles d'interventions dépassées !" 'Définition du sujet du mail
    adresse = Var 'Recherche l'adresse mail du destinataire
'MsgBox Desti & " - adresse mail : " & adresse
 
    'Définition du message
    message = "Bonjour, " & vbCrLf & vbCrLf & _
        "Nous vous informons que les délais d'exécution prévisionnels communiqués concernant les demandes de travaux figurant dans le document ci-joint sont dépassés. " & vbCrLf & _
        vbCrLf & "Merci de bien vouloir faire le nécessaire afin de régulariser ces demandes au plus vite et" & _
        " également informer les services demandeur des raisons de ce retard et des nouveaux délais d'exécution." & vbCrLf & _
        "Si les interventions ont été effectuées et qu'il s'agit d'un oubli de transmission, merci de bien vouloir nous retourner rapidement" & _
        " les fiches 'bon de travaux' correspondantes dûment renseignées afin de clôturer les demandes concernées." & vbCrLf & vbCrLf & _
        "Dans l'attente de vous lire," & vbCrLf & vbCrLf & _
        "Bien cordialement," & vbCrLf & vbCrLf & _
        "Le sécrétariat."
 
    'Paramètres de l'application mail
    Set OutlookApp = CreateObject("outlook.application")
    Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
            .Subject = sujet
            .To = adresse
            .Attachments.Add (ThisWorkbook.Path & "\" & "RelanceTravaux.pdf")
            .body = message
            .send 'Envoi du mail
            End With
    End If
End If
'MsgBox Desti & " - 4 - Verif Envoi mail"
 
'Supprime_filtre_alternative
'ActiveSheet.Unprotect ("CTM1410")
'If ActiveSheet.FilterMode Then
    ActiveSheet.Range("$A$2:$V$1500").AutoFilter Field:=12
    ActiveSheet.Range("$A$2:$V$1500").AutoFilter Field:=13
    ActiveSheet.Range("$A$2:$V$1500").AutoFilter Field:=14
'End If
'MsgBox Desti & " - 5 - Verif Réinitialisation Filtre"
 
'Supression du fichier transmis
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(ThisWorkbook.Path & "\" & "RelanceTravaux.pdf") 'supprimer le fichier
f.Delete
'MsgBox Desti & " - 6 - Verif Suppression Fichier"
 
Next_Desti:
Next Desti
 
ActiveSheet.Protect Password:="CTM1410", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingRows:=True, AllowFiltering:=True
 
errorHandler:
            If Err.Number > 0 Then
                'MsgBox "Envoi mail relance travaux : impossible d'effectuer cette opération !" & vbCrLf & "Merci de vérifier que Microsoft Outlook est bien ouvert !" & vbCrLf & _
                "Aucun mail n'a été envoyé ! - Erreur n° : " & Err.Number, vbCritical, "Attention !"
            End If
ShowAllData_fonctionne_a_priori_toujours
MsgBox "Les fichiers PDF correspondant ont été adressés aux différents destinataires !", vbInformation, "Félicitations !"
 
'Supression du fichier transmis
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(ThisWorkbook.Path & "\" & "RelanceDelai.pdf") 'supprimer le fichier
f.Delete
 
End Sub

Merci à tous ceux qui m'auront lu et qui avaient réfléchi à mon problème.

Cordialement.

[marccelestins]

Bonjour Hocked,

Je pense que tu pourras m'éclaircir avec le code que t'a envoyé. J'ai moi aussi un tcd avec différentes colonnes.j'ai dans mon tcd en colonne A différents mails et j'aimerais envoyer un mail à chaque destinataire. Dans le corps du mail j'aimerais récuperer les autres colonnes dans le corps du mail.
Exemple corps du mail : Bonjour & information colonne A & information colonne C et ainsi de suite.

¨Pourrais tu m'aider stp

Merci d'avance,