I want to extract all details form outlook emails in excel using vba according to particular word in subject of email

[vrsharma]

Hi Team,

I want to extract outlook emails data in excel using VBA according to specific words in subject of email. The subject of emails keep on changing but some part of the subject remains same of all the emails. eg. My email Subject is "Prod - Work Daily Alert for user Steve Johnson (1234567)" and I am using office 365 version
The Static part of the subject is: "Prod - Work Daily Alert for user" which remains same in all emails.
The Dynamic part of the subject is: "Steve Johnson (1234567)" which keeps on changing in every email.
I want extract data form email according to above static part.
I tried to use below VBA code by making some modification but it did not worked. It does not satisfy "If" condition so it does not extract anything from email and if I remove below code part from my code, then it extract all the data from the inbox.

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">"If InStr(olMail.Subject, "Prod - RECON Daily Alert for user") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then"</code>Please provide any solution for this.


<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Sub ExtractEmailContent()

Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim x As Date, ws As Worksheet
Dim lRow As Long

Set ws = ActiveSheet

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date

For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders

Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)

If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lRow).Offset(1, 0).Value = olMail.Subject
.Range("A" & lRow).Offset(1, 1).Value =
olMail.ReceivedTime
.Range("A" & lRow).Offset(1, 2).Value =
olMail.SenderName
.Range("A" & lRow).Offset(1, 3).Value = olMail.CC
.Range("A" & lRow).Offset(1, 4).Value = olMail.Body

End With
End If
End If
Next i

'forward_Email ()
Set olFolder = Nothing
Next eFolder
End Sub</code><code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">
</code>

 

[Worf]

Hi

Sub ExtractEmailContent()
Dim olApp As Outlook.Application, olNs As Namespace, olFolder As MAPIFolder, _
olMail As MailItem, eFolder As folder, i As Long, x As Date, ws As Worksheet, lRow&
Set ws = ActiveSheet
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = CDate("01/01/19")                   ' limit date
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).row
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
    For i = olFolder.Items.Count To 1 Step -1
        If TypeOf olFolder.Items(i) Is MailItem Then
            Set olMail = olFolder.Items(i)
            If InStr(olMail.Subject, "Umbrellas") > 0 And olMail.ReceivedTime > x Then
                    lRow = lRow + 1
                    ws.Range("A" & lRow).Offset(1) = olMail.Subject
                    ws.Range("A" & lRow).Offset(1, 1) = olMail.ReceivedTime
                    ws.Range("A" & lRow).Offset(1, 2) = olMail.SenderName
                    ws.Range("A" & lRow).Offset(1, 3) = olMail.cc
                    ws.Range("A" & lRow).Offset(1, 4) = olMail.Body
            End If
        End If
    Next
    Set olFolder = Nothing
Next
End Sub

 

[vrsharma]

Hi Worf,
Thank you so much for your help, it is working fine now.

 

[JACOBB9900]

Hello,

Is there a way to run this VBA automatically. For instance, I am using a VBA code to extract emails from a specific folder. I've added the macro to a button on the worksheet which I have to press in order to refresh and extract any current emails. Can this code be automated so it is constantly pulling emails out of that folder?

Thank you.

 

[Worf]

Would you like to run it at a particular time of the day? How many times per day?

 

[JACOBB9900]

Essentially I would like for it to refresh whenever a new email is received in that folder, but I'm not sure if that's possible. If it could automatically run four times a day that would be great as well. Is that a possibility?

Thank you.

 

[Worf]

Outlook has a new mail event, which can be used to automatically execute a macro. Can you try to reproduce the example in the page below?
If we choose not to use it, Excel has an On Time method that allows scheduling code execution.

https://docs.microsoft.com/en-us/office/vba/api/outlook.application.newmail