Extraction de données sur mail Outlook reçu puis saisie sur tableau Excel

Bonjour,

Existerait-il une macro qui puisse faire la manip suivante ?

Pour chaque mail outlook reçu de "mail.groupes.paris@airfrance.fr" et qui comporte en objet : "Enregistrement de l'acompte du dossier" est-il possible d'extraire la date de réception figurant dans l'en-tête du mail : 11/11/23 18:43 ainsi que 0575018469002 et 6060023 ? (en PJ)

Ces 3 données sont variables et sont à reporter dans un tableau excel qui se trouve C:\Users\MONNOM\MASOCIETE\Transport - Documents\EMD AIR FRANCE POUR 2023\accusé de réception EMD acompte AF.

Lorsque les données sont enregistrées dans le tableau excel, le mail est à supprimer.

Pour chaque mail cible, les données sont à enregistrer dans le tableau excel à la ligne suivante disponible.

Merci par avance pour votre aide !

Kirii57

Bonjour,

ci-dessous exemple de macro à insérer dans votre office 365 Outlook ( Editeur VBA --> ThisOutlookSession)

Option Explicit

Private WithEvents email As Outlook.MailItem

Private Sub Application_ItemLoad(ByVal Item As Object)

    If Item.Class <> olMail Then Exit Sub

    'assignation variable objet email pour activation des evts email
    Set email = Item
End Sub

Private Sub email_Read()
    Dim xl As Object, wb As Object
    Dim EMD As String, TIGRE_WEB As String, nom_fichier As String
    Dim début As Integer, i As Integer
    Dim ligne As Object

    Const dossier As String = "Enregistrement de l'acompte du dossier "
    Const document As String = "L'enregistrement du document n°"

    '// sélection email
    If email.SenderEmailAddress <> "mail.groupes.paris@airfrance.fr" Then Exit Sub
    If InStr(1, email.Subject, dossier) = 0 Then Exit Sub

    '// récupération n° dossier
    début = InStr(1, email.Subject, dossier) + Len(dossier)
    i = 0
    While IsNumeric(Mid(email.Subject, début + i, 1))
        EMD = EMD & Mid(email.Subject, début + i, 1)
        i = i + 1
    Wend

    '// récupération n° document
    début = InStr(1, email.Body, document) + Len(document)
    i = 0
    While IsNumeric(Mid(email.Body, début + i, 1))
        TIGRE_WEB = TIGRE_WEB & Mid(email.Body, début + i, 1)
        i = i + 1
    Wend

    '// création instance EXCEL
    Set xl = CreateObject("Excel.application")

    '// ouverture fichier
    nom_fichier = Environ("userprofile") & "\MASOCIETE\Transport - Documents\EMD AIR FRANCE POUR 2023\accusé de réception EMD acompte AF.xlsm"
    On Error Resume Next
    Set wb = xl.Workbooks.Open(nom_fichier)
    If Err.Number <> 0 Then MsgBox "Erreur ouverture fichier " & nom_fichier: Exit Sub

    '// ajout accusé de réception
    With wb.sheets(1).listobjects(1)
        Set ligne = .ListRows.Add: i = ligne.Index 'ajout ligne
        If Err.Number <> 0 Then MsgBox "Erreur ajout accusé de réception dans tableau structuré": Exit Sub

        .listcolumns("EMD").databodyrange(i) = EMD
        .listcolumns("TIGRE WEB").databodyrange(i) = TIGRE_WEB
        .listcolumns("DATE DE SAISIE DU TW").databodyrange(i) = email.ReceivedTime
    End With

    '// sauvegarde fichier et fermeture instance Excel
    wb.Close SaveChanges:=True
    If Err.Number <> 0 Then MsgBox "Erreur fermeture fichier": Exit Sub
    xl.Quit

    'suppression email
    email.Delete

End Sub

Vous êtes génial, ça fonctionne ! Merci beaucoup !

Dernier souci : l'acompte commence en fait par un 0 (zéro). Dans le tableau excel, la valeur extraite n'apparaît pas 0575018469007 mais comme selon 5,75018E+11. Est-ce qu'il vous serait possible de corriger l'affichage comme selon : 0575018469007 ? Si c'est trop compliqué, pourriez-vous retirer dans la valeur extraite les 3 premiers caractères "057", svp ? Désolé de réaliser cela que maintenant 😔...

Est-ce qu'il vous serait possible de corriger l'affichage comme selon : 0575018469007 ?

Rien de plus simple. Il suffit de mettre au format texte les colonnes concernées de votre tableau structuré.

Merci THEV, compris ! Je me rends compte qu'il doit y avoir collusion sur le tableau excel. Ce document est partagé. Je peux y avoir accès par ONE DRIVE et par SHAREPOINT. Est-ce que ce problème est résolvable ?

Excel indique que mon tableau est ouvert dans une autre application. Veuillez fermer ce fichier et réessayer. J'ai ce message d'erreur alors que j'ai tout fermé.

Peut-être dû à un problème de synchro... ? Bonne soirée.

Excel indique que mon tableau est ouvert dans une autre application.

Sans doute que suite à une erreur, l'instance d'Excel créée dans Outlook n'a pas été fermée. Dans le gestionnaire des tâches --> Processus --> Processus en arrière-plan, terminer l'instance Microsoft Excel si elle existe.

Excel indique que mon tableau est ouvert dans une autre application.

D'ailleurs, ce serait mieux de fermer l'instance d'Excel en cas d'erreur. Rectifier le code comme suit :

    '// création instance EXCEL
    Set xl = CreateObject("Excel.application")

    '// ouverture fichier
    nom_fichier = Environ("userprofile") & "\MASOCIETE\Transport - Documents\EMD AIR FRANCE POUR 2023\accusé de réception EMD acompte AF.xlsm"
    On Error Resume Next
    Set wb = xl.Workbooks.Open(nom_fichier)
    If Err.Number <> 0 Then MsgBox "Erreur ouverture fichier " & nom_fichier: xl.Quit: Exit Sub

    '// ajout accusé de réception
    With wb.sheets(1).listobjects(1)
        Set ligne = .ListRows.Add: i = ligne.Index 'ajout ligne
        If Err.Number <> 0 Then MsgBox "Erreur ajout accusé de réception dans tableau structuré": xl.Quit: Exit Sub

        .listcolumns("EMD").databodyrange(i) = EMD
        .listcolumns("TIGRE WEB").databodyrange(i) = TIGRE_WEB
        .listcolumns("DATE DE SAISIE DU TW").databodyrange(i) = email.ReceivedTime
    End With

    '// sauvegarde fichier et fermeture instance Excel
    wb.Close SaveChanges:=True
    If Err.Number <> 0 Then MsgBox "Erreur fermeture fichier": xl.Quit: Exit Sub
    xl.Quit

    'suppression email
    email.Delete

End Sub

J'ai ce message qui apparaît :

Je crois que cette version excel bureau est trop avancée pour moi... La ligne 12 est apparue...

J'ai le message suivant :

Sur 2 déclenchements de la macro, les valeurs TW et EMD ont été intervertie entre la colonne A et la colonne C

Voici la macro que j'utilise :

Option Explicit

Private WithEvents email As Outlook.MailItem

Private Sub Application_ItemLoad(ByVal Item As Object)

If Item.Class <> olMail Then Exit Sub

'assignation variable objet email pour activation des evts email
Set email = Item
End Sub

Private Sub email_Read()
Dim xl As Object, wb As Object
Dim EMD As String, TIGRE_WEB As String, nom_fichier As String
Dim début As Integer, i As Integer
Dim ligne As Object

Const dossier As String = "Enregistrement de l'acompte du dossier "
Const document As String = "L'enregistrement du document n°"

'// sélection email
If email.SenderEmailAddress <> "mail.groupes.paris@airfrance.fr" Then Exit Sub
If InStr(1, email.Subject, dossier) = 0 Then Exit Sub

'// récupération n° dossier
début = InStr(1, email.Subject, dossier) + Len(dossier)
i = 0
While IsNumeric(Mid(email.Subject, début + i, 1))
EMD = EMD & Mid(email.Subject, début + i, 1)
i = i + 1
Wend

'// récupération n° document
début = InStr(1, email.Body, document) + Len(document)
i = 0
While IsNumeric(Mid(email.Body, début + i, 1))
TIGRE_WEB = TIGRE_WEB & Mid(email.Body, début + i, 1)
i = i + 1
Wend

'// création instance EXCEL
Set xl = CreateObject("Excel.application")

'// ouverture fichier
nom_fichier = Environ("userprofile") & "\OneDrive - LES ARTS ET LA VIE\Documents partages - Transport\EMD AIR FRANCE POUR 2023\accusé de réception EMD acompte AF\Accusés de réception des EMD par AF.xlsx"
On Error Resume Next
Set wb = xl.Workbooks.Open(nom_fichier)
If Err.Number <> 0 Then MsgBox "Erreur ouverture fichier " & nom_fichier: xl.Quit: Exit Sub

'// ajout accusé de réception
With wb.sheets(1).listobjects(1)
Set ligne = .ListRows.Add: i = ligne.Index 'ajout ligne
If Err.Number <> 0 Then MsgBox "Erreur ajout accusé de réception dans tableau structuré": xl.Quit: Exit Sub

.listcolumns("EMD").databodyrange(i) = EMD
.listcolumns("TIGRE WEB").databodyrange(i) = TIGRE_WEB
.listcolumns("DATE DE SAISIE DU TW").databodyrange(i) = email.ReceivedTime
End With

'// sauvegarde fichier et fermeture instance Excel
wb.Close SaveChanges:=True
If Err.Number <> 0 Then MsgBox "Erreur fermeture fichier": xl.Quit: Exit Sub
xl.Quit

'suppression email
email.Delete

End Sub

Je ne vois pas où est le problème... Je pense qu'on y est presque...

Bonne soirée

Bonsoir,

Votre tableau structuré n'a pas l'air stable.

Une formule apparait dans la colonne EMD ??

Vos noms de colonne changent : Tigre Web au lieu de TIGRE WEB. Ne pas oublier que la macro utilise les noms de colonne, donc .ListColumns("TIGRE WEB") n'existe plus et provoque une erreur.

Bonsoir Thev,

Merci d'avoir pris la peine de me répondre. Je regarderai demain.

Bonsoir Thev,

Merci pour votre aide. Votre formule corrigée fonctionne très bien. Quand j'ai de nombreux messages à extraire, cela fini par bugger = j'ai un message d'erreur qui m'informe qu'excel va enregistrer 2 versions. Alors, lorsque j'y ai accès, je corrige et en supprime une. Je considère que c'est résolu.