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.