VBA trier par date

Bonjour,

J’ai besoin de votre aide.

J’ai un fichier Excel qui qui recense les interventions de maintenance, le but est à l’aide d’un bouton d’envoyer un mail avec en PJ un fichier PDF de toutes les interventions de la veille. Mais je n’arrive pas trier pour envoyer seulement les interventions de la veille. Ci-joint le code ainsi qu’un fichier exemple.

Merci par avance de votre aide

Cordialement

Sub Bouton1_Cliquer()

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Créer une instance Windows Script pour retrouver le chemin du bureau

sRep = Environ("temp")

For i = 1 To 100
    If Worksheets("Résumer Mail").Range("B" & i) = Date - 1 Then
    Worksheets("Résumer Mail").Range("A3:F13").ExportAsFixedFormat Type:=xlTypePDF, Filename:="Résumer.pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End If
Next i

Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
    .To = "t...........fr"
    .CC = ""
    .Attachments.Add ("Résumer.pdf")
    .Subject = "Résumé interventions"
    .Body = "Bonjour" & vbNewLine & vbNewLine & _
            "Ci-joint un résumé des interventions d'hier" & vbNewLine & vbNewLine & _
            "Cordialement"
    .Display
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

Kill ("Résumer.pdf")

End Sub

Bonjour,

Il vous faut définir ce qu'est la veille du jour dans votre semaine de travail. Le plus simple consiste à créer un calendrier et d'aller chercher la veille en fonction de la date du jour, et lancer le mail seulement si au moins 1 enregistrement existe.

Option Explicit

Sub FiltrerLeTableau()

 Dim MaDate As Date
 Dim ShDonnees As Worksheet
 Dim Chemin As String

 Dim OutApp As Object, OutMail As Object

     If Range("NombreLignes") = 0 Then
        MsgBox "Aucunes données pour la date du " & Range("VeilleDuJour")
        Exit Sub
     End If

     MaDate = CDate(Range("VeilleDuJour"))
     Set ShDonnees = Worksheets("Résumer Mail")

     Chemin = ThisWorkbook.Path & "\Résumé " & DateFichier(MaDate) & ".pdf"

     With ShDonnees
          If .FilterMode Then .ShowAllData
          .ListObjects("Tableau1").Range.AutoFilter Field:=2, Operator:= _
           xlFilterValues, Criteria2:=Array(2, Format(MaDate, "mm/dd/yyyy"))
          .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
          IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
     End With

    Set OutApp = CreateObject("outlook.application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "A....fr"
        .CC = ""
        .Attachments.Add Chemin
        .Subject = "Résumé des interventions du " & DateFichier(MaDate)
        .Body = "Bonjour" & vbNewLine & vbNewLine & _
                "Ci-joint un résumé des interventions d'hier" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Display
    End With

    Kill Chemin

     Set ShDonnees = Nothing
     Set OutApp = Nothing: Set OutMail = Nothing

End Sub

Function DateFichier(ByVal MaDate2 As Date) As String

    DateFichier = Year(MaDate2) & "-" & Format(Month(MaDate2), "00") & "-" & Format(Day(MaDate2), "00")

End Function

Bonjour,

merci de votre réponse ça fonctionne, mais j'aimerais que lorsque le mail à était envoyer le filtre s'annule.

cordialement

Il suffit d'ajouter la ligne .filtermode... après la création du fichier pdf.

ça ne fonctionne pas

Quel est votre code ?

Option Explicit

Sub FiltrerLeTableau()

 Dim MaDate As Date
 Dim ShDonnees As Worksheet
 Dim Chemin As String

 Dim OutApp As Object, OutMail As Object

     If Range("NombreLignes") = 0 Then
        MsgBox "Aucunes données pour la date du " & Range("VeilleDuJour")
        Exit Sub
     End If

     MaDate = CDate(Range("VeilleDuJour"))
     Set ShDonnees = Worksheets("Résumer Mail")

     Chemin = ThisWorkbook.Path & "\Résumé " & DateFichier(MaDate) & ".pdf"

     With ShDonnees
        On Error Resume Next
          If .FilterMode Then .ShowAllData
          .ListObjects("Tableau1").Range.AutoFilter Field:=2, Operator:= _
           xlFilterValues, Criteria2:=Array(2, Format(MaDate, "mm/dd/yyyy"))
          .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
          IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
     End With

    Set OutApp = CreateObject("outlook.application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "A....fr"
        .CC = ""
        .Attachments.Add Chemin
        .Subject = "Résumé des interventions du " & DateFichier(MaDate)
        .Body = "Bonjour" & vbNewLine & vbNewLine & _
                "Ci-joint un résumé des interventions d'hier" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Display

    End With

    Kill Chemin

     Set ShDonnees = Nothing
     Set OutApp = Nothing: Set OutMail = Nothing

End Sub

Function DateFichier(ByVal MaDate2 As Date) As String

    DateFichier = Year(MaDate2) & "-" & Format(Month(MaDate2), "00") & "-" & Format(Day(MaDate2), "00")

End Function

Vous n'avez pas modifié comme indiqué dans mon message précédent.

Il suffit d'ajouter la ligne If .FilterMode Then .ShowAllData après la création du fichier pdf.

je l'est enlever car ça ne fonctionne pas.

Option Explicit

Sub FiltrerLeTableau()

 Dim MaDate As Date
 Dim ShDonnees As Worksheet
 Dim Chemin As String

 Dim OutApp As Object, OutMail As Object

     If Range("NombreLignes") = 0 Then
        MsgBox "Aucunes données pour la date du " & Range("VeilleDuJour")
        Exit Sub
     End If

     MaDate = CDate(Range("VeilleDuJour"))
     Set ShDonnees = Worksheets("Résumer Mail")

     Chemin = ThisWorkbook.Path & "\Résumé " & DateFichier(MaDate) & ".pdf"

     With ShDonnees
        On Error Resume Next
          If .FilterMode Then .ShowAllData
          .ListObjects("Tableau1").Range.AutoFilter Field:=2, Operator:= _
           xlFilterValues, Criteria2:=Array(2, Format(MaDate, "mm/dd/yyyy"))
          .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin, Quality:=xlQualityStandard, _
          IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
           If .FilterMode Then .ShowAllData
     End With

    Set OutApp = CreateObject("outlook.application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "A....fr"
        .CC = ""
        .Attachments.Add Chemin
        .Subject = "Résumé des interventions du " & DateFichier(MaDate)
        .Body = "Bonjour" & vbNewLine & vbNewLine & _
                "Ci-joint un résumé des interventions d'hier" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Display

    End With

    Kill Chemin

     Set ShDonnees = Nothing
     Set OutApp = Nothing: Set OutMail = Nothing

End Sub

Function DateFichier(ByVal MaDate2 As Date) As String

    DateFichier = Year(MaDate2) & "-" & Format(Month(MaDate2), "00") & "-" & Format(Day(MaDate2), "00")

End Function

Dernier envoi.

Bon courage à vous.