VBA macro that checks a specific inbox email and update an Excel spreadsheet based on the information inside

AedmiO

New Member
Joined
Jul 28, 2021
Messages
5
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
  2. Mobile
  3. Web
Hello everyone,
I'm currently doing a little project and would like to automatically update an Excel sheet based on the information taken from an Outlook mail from the Inbox folder using Outlook VBA. So while doing my research on the topic, I found this topic Macro to read email and update spreadsheet and think that it is kind of similar to what I'm looking for. The problem is what I want to do is a little bit different. First there will be more than two cells to be modified and they will be on different rows and different columns. Secondly, the e-mail that I will receive may look and work differently. I'm new to VBA and checked some thread on my topic and some youtube videos to learn VBA and I'm also trying to learn the specific stuffs linked to what I'm want to do. That's why I'd like to ask if you could guys help me (by providing me a code that performs what I'm looking for, whether it is complete or not) or give me directions to anything you deem worthful to check so that I could understand the new code or the code in the linked topic and maybe modify it to suit my needs.
I've linked several photos of the Excel sheet and the Outlook mail (with made-up data ) so that you could understand my situation a little bit better. There is also the final code used by the linked url's original poster to resolve his problem.
The data that will be updated are the end and start dates, the end and start hours, the service provider and the severity level. the devices whose data will be updated are the ones whose cells are filled in red.
I don't really know how the mail of the guy in the linked topic looks or works but if you have any idea on how my mail should look or works to make my objective possible, feel free to share it. The same thing applies to my excel sheet if I need to make some adjustment to make it works.

VBA Code:
Public Sub Update_Products_Sold()

    Dim outApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outFolder As Outlook.MAPIFolder
    Dim outItem As Object
    Dim outMail As Outlook.MailItem
    Dim product1 As Range, product2 As Range
    Dim lastRunReceivedTime As Range, latestReceivedTime As Date
    Dim parts As Variant, quantitySold As Integer
    Dim numEmailsFound As Integer
    
    With ThisWorkbook.Worksheets("Overview")
        Set product1 = .Range("F5")
        Set product2 = .Range("F7")
        Set lastRunReceivedTime = .Range("B1")
    End With
    
    Set outApp = New Outlook.Application
    Set outNs = outApp.GetNamespace("MAPI")
    
    'Get ebay subfolder within Inbox folder
    
    Set outFolder = outNs.GetDefaultFolder(olFolderInbox).Folders("ebay")
    
    'Loop through emails
    
    latestReceivedTime = lastRunReceivedTime.Value
    numEmailsFound = 0
    For Each outItem In outFolder.Items
    
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            
            Set outMail = outItem
            
            'Is this email from ebay and received after the latest received time of the last run?
            
            If outMail.ReceivedTime > lastRunReceivedTime.Value And _
                  InStr(1, outMail.SenderEmailAddress, "@ebay", vbTextCompare) > 0 Then
                            
                'Yes, so extract quantity sold, identify product type in subject and update appropriate Excel cell
                
                'MsgBox outMail.Body, Title:=outMail.Subject
                parts = Split(outMail.Body, "Quantity sold:")
                quantitySold = Split(parts(1), vbCrLf)(0)
                
                If InStr(1, outMail.Subject, "LEATHER", vbTextCompare) > 0 Then
                    product1.Value = product1.Value + quantitySold
                    numEmailsFound = numEmailsFound + 1
                ElseIf InStr(1, outMail.Subject, "PVC", vbTextCompare) > 0 Then
                    product2.Value = product2.Value + quantitySold
                    numEmailsFound = numEmailsFound + 1
                End If
                
                'Update latest received time
                
                If outMail.ReceivedTime > latestReceivedTime Then latestReceivedTime = outMail.ReceivedTime
                
            End If

        End If
    Next
    
    'Update cell containing latest received time of an ebay email
    
    lastRunReceivedTime.Value = latestReceivedTime
    lastRunReceivedTime.NumberFormat = "dd/mm/yyyy hh:mm:ss"

    MsgBox "Finished." & vbNewLine & "Number of emails found = " & numEmailsFound
    
End Sub

Any advice is welcome and thank you for your time.
 

Attachments

  • 1.PNG
    1.PNG
    108.4 KB · Views: 95
  • 2.PNG
    2.PNG
    129.2 KB · Views: 95
  • 3.PNG
    3.PNG
    74 KB · Views: 93

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Could anyone help me to modify it ?
My idea is to update the excel sheet based on the information inside the mail. The information of the rows filled in red in the Excel will be replaced by the information of the rows filled in red in the mail. Preferably for both of the sheets but even one sheet would be a relief. I don’t know how to do it but I thought that the program could look for the ID number in the body of the mail but also in the excel file and if the ID numbers match, replace the information on the row of the Excel file for this ID number with the information on the row of the mail with the same ID number.
Here's what I tried to do for now but not having much knowledge on the subject and lacking both Excel sheet and email they used for this code, I couldn't understand much.

VBA Code:
Public Sub Update_Excel_Details()

Dim outApp As Outlook.Application
    Dim outNs As Outlook.NameSpace
    Dim outFolder As Outlook.MAPIFolder
    Dim outItem As Object
    Dim outMail As Outlook.MailItem
    Dim P1 As Range, P2 As Range, P3 As Range, P4 As Range, P5 As Range, P6 As Range
    Dim lastRunReceivedTime As Range, latestReceivedTime As Date
     Dim Severity_level As Integer, Start_date As Date, Start_hour As Variant, End_date As Date, End_hour As Variant, Service_provider As String
    Dim numEmailsFound As Integer
    
    With ThisWorkbook.Worksheets("Projet")
    For x = 3 To 11
        Set P1 = .Range("E" & x)
        Set P2 = .Range("F" & x)
        Set P3 = .Range("G" & x)
        Set P4 = .Range("H" & x)
        Set P5 = .Range("I" & x)
        Set P6 = .Range("J" & x)
        x = x + 1
        Next x
        Set lastRunReceivedTime = .Range("A1")
    
    End With
    
    Set outApp = New Outlook.Application
    Set outNs = outApp.GetNamespace("MAPI")
    
    'Get Drafts folder
    
    Set outFolder = outNs.GetDefaultFolder(olFolderDrafts)
    
    'Loop through emails
    
    latestReceivedTime = lastRunReceivedTime.Value
    numEmailsFound = 0
    For Each outItem In outFolder.Items
    
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            
            Set outMail = outItem
            
            'Is this email from mimi and received after the latest received time of the last run?
            
            If outMail.ReceivedTime > lastRunReceivedTime.Value And _
                  InStr(1, outMail.SenderEmailAddress, "@mimi", vbTextCompare) > 0 Then
                            
                'Identify ID number in the row and update appropriate Excel cell
                
                'MsgBox outMail.Body, Title:=outMail.Subject
                parts = Split(outMail.Body, "Severity_level")
                parts = Split(outMail.Body, "Start_date ")
                parts = Split(outMail.Body, "Start_hour")
                parts = Split(outMail.Body, "End_date")
                parts = Split(outMail.Body, "End_hour")
                parts = Split(outMail.Body, "Service_provider")
                Severity_level = Split(parts(1), vbCrLf)(0)
                Start_date = Split(parts(1), vbCrLf)(0)
                Start_hour = Split(parts(1), vbCrLf)(0)
                End_date = Split(parts(1), vbCrLf)(0)
                End_hour = Split(parts(1), vbCrLf)(0)
                Service_provider = Split(parts(1), vbCrLf)(0)
                
                If InStr(1, outMail.Subject, "July", vbTextCompare) > 0 Then
                    P1.Value = Severity_level
                    P2.Value = Start_date
                    P3.Value = Start_hour
                    P4.Value = End_date
                    P5.Value = End_hour
                    P6.Value = Service_provider
                    numEmailsFound = numEmailsFound + 1
                ElseIf InStr(1, outMail.Subject, "August", vbTextCompare) > 0 Then
                Worksheets(2).Select
                    P1.Value = Severity_level
                    P2.Value = Start_date
                    P3.Value = Start_hour
                    P4.Value = End_date
                    P5.Value = End_hour
                    P6.Value = Service_provider
                    numEmailsFound = numEmailsFound + 1
                End If
                
                'Update latest received time
                
                If outMail.ReceivedTime > latestReceivedTime Then latestReceivedTime = outMail.ReceivedTime
                
            End If

        End If
    Next
    
    'Update cell containing latest received time of an ebay email
    
    lastRunReceivedTime.Value = latestReceivedTime
    lastRunReceivedTime.NumberFormat = "dd/mm/yyyy hh:mm:ss"

    MsgBox "Finished." & vbNewLine & "Number of emails found = " & numEmailsFound
    
End Sub

I modified the Excel sheet a little bit because I tried incorporate in, the last received time range to be able to input it in A1 and also check it.
Thank you for your time !
 

Attachments

  • 1.PNG
    1.PNG
    82.8 KB · Views: 47
  • 2.PNG
    2.PNG
    77.5 KB · Views: 47
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,148
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top