Import each Email from outlook into the next row of excel

[cairo95]

Hello! hope you're doing well!

i need assistance with the following task..i have a rule sending specific emails to a folder in outlook...i found the following code on youtube and modified it to allow me to enter the email folder name in a specific cell. my problem is due to my limited VB coding capabilities i cannot figure out how to import separate emails into the next row...currently it imports all emails into one row and because of that...the information is fragmented. if possible i would like each row in the email to import into its own row in excel.

Sub getDataFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim emailFolderName As String
emailFolderName = Worksheets("Sheet7").Range("email_folder_name")

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders(emailFolderName)

 
i = 1
For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("Receive_Date").Value Then
    Range("Email_Subject").Offset(1, 0) = OutlookMail.Subject
    Range("Email_Subject").Offset(1, 0).Columns.AutoFit
    Range("Email_Subject").Offset(1, 0).VerticalAlignment = xlTop
    
    Range("Date_of_Email").Offset(1, 0).Value = OutlookMail.ReceivedTime
    Range("Date_of_Email").Offset(1, 0).Columns.AutoFit
    Range("Date_of_Email").Offset(1, 0).VerticalAlignment = xlTop
     
    Range("Sender_of_Email").Offset(1, 0).Value = OutlookMail.SenderName
    Range("Sender_of_Email").Offset(1, 0).Columns.AutoFit
    Range("Sender_of_Email").Offset(1, 0).VerticalAlignment = xlTop
     
    Range("Body_of_Email").Offset(1, 0).Value = OutlookMail.Body
    Range("Body_of_Email").Offset(1, 0).Columns.AutoFit
    Range("Body_of_Email").Offset(1, 0).VerticalAlignment = xlTop
      
     
    i = i + 1
    End If
   Next OutlookMail
   
   
   Set Folder = Nothing
   Set OutlookNamespace = Nothing

end sub

each email contains the following information:

SOURCEMESSAGE AWBPREFIX AWBNUMBER REASON MESSAGECONTENT MESSAGESTATUS TIME
FSU 001 35014103 DFWNO ACTIVE UNIT FOUND IN AWB ICARGO3 .HDQFMAA 040430 FNA/1 ACK/NO ACTIVE UNIT FOUND IN AWB FSU/14 001-35014103AMSTUL/T1K23 PRE/AA203/04OCT/AMSPHL/T1K23/S1055/S1345 OSI/PMC15623AA PS 2019-10-04 04:30:05.938
FSU 001 20705565 DFWAWB NOT LOG RECEIVED ICARGO3 .HDQFMAA 040431 FNA/1 ACK/AWB NOT LOG RECEIVED FSU/14 001-20705565AMSBOS/T1K240 PRE/AA203/04OCT/AMSPHL/T1K240/S1055/S1345 OSI/PMC05012US PS 2019-10-04 04:31:32.691
FSU 001 22498033 DFWNO ACTIVE UNIT FOUND IN AWB ICARGO3 .HDQFMAA 040433 FNA/1 ACK/NO ACTIVE UNIT FOUND IN AWB FSU/14 001-22498033LHRDFW/T8K68 PRE/AA021/04OCT/LHRDFW/T8K68/S0840/S1300 OSI/PMC15057AA PS 2019-10-04 04:33:03.658
FSU 001 23645392 DFWCONSIGNMENT ORI STA .SWKERR ICARGO3 .HDQFMAA 040434 FNA/1 ACK/CONSIGNMENT ORI STA .SWKERR FSU/14 001-23645392SWKCLT/T1K110 PRE/AA8766/03OCT/MILFCO/T1K110/S2000/S0600-N OSI/MIL8766B PS 2019-10-04 04:34:34.763
FSU 001 23549175 DFWCONSIGNMENT ORI STA .MXPERR ICARGO3 .HDQFMAA 040434 FNA/1 ACK/CONSIGNMENT ORI STA .MXPERR FSU/14 001-23549175MXPSFO/T1K4.5 PRE/AA8766/03OCT/MILFCO/T1K4.5/S2000/S0600-N OSI/MIL8766B PS 2019-10-04 04:34:34.878
FSU 001 21906662 DFWCONSIGNMENT ORI STA .SWKERR ICARGO3 .HDQFMAA 040434 FNA/1 ACK/CONSIGNMENT ORI STA .SWKERR FSU/14 001-21906662SWKORD/T1K142 PRE/AA8766/03OCT/MILFCO/T1K142/S2000/S0600-N OSI/MIL8766B PS 2019-10-04 04:34:34.986
FSU 001 21395194 DFWCONSIGNMENT ORI STA .SWKERR ICARGO3 .HDQFMAA 040434 FNA/1 ACK/CONSIGNMENT ORI STA .SWKERR FSU/14 001-21395194SWKSLC/T1K65 PRE/AA8766/03OCT/MILFCO/T1K65/S2000/S0600-N OSI/MIL8766B PS 2019-10-04 04:34:35.013
FSU 001 23069675 DFWNO ACTIVE UNIT FOUND IN AWB ICARGO3 .HDQFMAA 040433 FNA/1 ACK/NO ACTIVE UNIT FOUND IN AWB FSU/14 001-23069675LHRDFW/T15K155 PRE/AA021/04OCT/LHRDFW/T15K155/S0840/S1300 OSI/PMC15057AA PS 2019-10-04 04:33:03.745

i would like each row in the emails to import into separate rows in excel. then i can format it in another column.

Thank you so much!

Cairo95

 

[Rijnsent]

Hi Cairo95,
replace: Offset(1, 0) by Offset(i, 0) -> that should put the conents of the next iteration on the next row.
Cheers,
Koen

 

[cairo95]

Hi Cairo95,
replace: Offset(1, 0) by Offset(i, 0) -> that should put the conents of the next iteration on the next row.
Cheers,
Koen

Thanks Koen, that is what I did a couple days ago. I was hoping to have each row in the email imported to each excel row. what this does is import the whole body into the cell then the next email body into the next cell...but I was able to work with it perform few steps more.

thanks for your help.

Cairo95

 

[John_w]

Untested. As well as the Offset change, replace:

Range("Body_of_Email").Offset(1, 0).Value = OutlookMail.Body

with:

Dim lines As Variant, r As Long
lines = Split(OutlookMail.Body, vbCrLf)
For r = 0 To Ubound(lines)
    Range("Body_of_Email").Offset(i+r, 0).Value = lines(r)
Next

and:

i = i + 1

with:

i = i + r

 

[cairo95]

worked perfectly!!! thank you so much!

Cairo95