How to copy partial e-mail body in excel

ThrottleWorks · Jan 23, 2018

Hi,

I am searching 2 key words in e-mail body.
I am getting their start points with the code.

How do I copy e-mail body within these 2 key words in excel.
Can anyone please help me in this.

I am using below code to get starting points.
I want to copy data between SLine and ELine in excel.

Code:

For Each oins In oApp.Inspectors
        Dim outlookApp
        Dim olNs As Outlook.Namespace
        Dim Fldr As Outlook.MAPIFolder
        Dim olMail As Variant
        Dim myTasks
        Dim sir() As String
      
        Set outlookApp = CreateObject("Outlook.Application")
        Set olNs = outlookApp.GetNamespace("MAPI")
        Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
        Set myTasks = Fldr.Items
      
        Dim SLine As Long
        Dim ELine As Long
      
        If (InStr(1, oins.CurrentItem.Body, "From: ", vbTextCompare) > 0) Then
            SLine = InStr(1, oins.CurrentItem.Body, "From: ", vbTextCompare)
            MsgBox SLine
        End If
      
        If (InStr(1, oins.CurrentItem.Body, "Subject: ", vbTextCompare) > 0) Then
            ELine = InStr(1, oins.CurrentItem.Body, "Subject: ", vbTextCompare)
            MsgBox ELine
        End If
    Next

Chihiro · Jan 23, 2018

Can't you just use Mid?

Ex:

Code:

Debug.Print Mid(oins.CurrentItem.Body, SLine + 6, ELine - SLine - 6)

Chihiro · Jan 23, 2018

Or if your purpose is to extract email address from email body...

You can just use RegEx to extract matches to pattern.

If you need help with pattern matching, post several examples of email body that contains From: ~ Subject:.

ThrottleWorks · Jan 23, 2018

Hi @Chihiro sir,

Can't you just use Mid?

This is working. Thanks a lot. I was not aware that I could use MID to get e-mail body.

ThrottleWorks · Jan 23, 2018

Hi @Chihiro sir, yes, I am trying to get e-mail address details from the latest chain of e-mail.

Example 1 for your reference.

From: ab abc [mailto:ab.abc@y.com]
Sent: 23 January 2018 18:31
To: qq w eeee
Cc: qaz wsxe; wsx, ed (uiiii iuuu & pppp lll)

Now I am trying to get each name or address in different cell of exce.
In above example, we have 5 names or address, so I am trying to fill range B1:B5 with each name or e-mail address.

Please give me some time to post more examples.

ThrottleWorks · Jan 23, 2018

Please see example 2.
I am getting below text in cell A1.
From ce11 A1 I need to get each name or e-mail address in different cell of excel. May be B column. How do I do this.

From: Rahul Dravid [mailto:Rahul.Dravid@Company.Com]
Sent: 1 November 2001 15:47
To: Brian Lara; CcC_CC; Rohit Sharma; Sharad Pawar; Narendra Modi; Modi, Narendra (Operations); Awesome_Managers; Salil Ankola; Singh, Yuvraj (AA AAA & AAAA AAAAA); Nayan Mongia [BCCI]; Salman Shahrukh Khan; Salil Ankola [BCCI]; Ravi.Shastri@BCCI.com'; Manjrekar, Sanjay (ABC ABCDEFG Operations); wow.wagh@yy.com; ABC_Damagers; 'Ravi.Shastri@BCCI.com'; Virat Sharma; Arun Shourie; Jaspreet Bumrah; Bumrah, Jaspreet (shared work shared sallary); Nayan Mongia
Cc: AA, AAB (shared work shared sallary); CCC, DDDD (ABC ABCDEFG Operations); Marc.Donald@secondcompany.com; Bumrah, Jaspreet (shared work shared sallary); sruname, name (ABC ABCDEFG Operations)
Subject: RE: Why I am doing this

ThrottleWorks · Jan 23, 2018

Result I am trying to get will be as below.

Rahul Dravid
Rahul.Dravid@Company.Com
Brian Lara
CcC_CC
Rohit Sharma
Sharad Pawar
Narendra Modi
Modi, Narendra
Awesome_Managers
Salil Ankola
Singh, Yuvraj
Nayan Mongia
Salman Shahrukh Khan
Salil Ankola
Ravi.Shastri@BCCI.com
Manjrekar, Sanjay
wow.wagh@yy.com
ABC_Damagers
Ravi.Shastri@BCCI.com
Virat Sharma
Arun Shourie
Jaspreet Bumrah
Bumrah, Jaspreet
Nayan Mongia
AA, AAB
CCC, DDDD
Marc.Donald@secondcompany.com
Bumrah, Jaspreet
sruname, name

Chihiro · Jan 23, 2018

Hmm, then just string manipulation is best bet. Since, you are not just looking for email pattern (xxx@xxx.xx)

Or you can use something like below to traverse conversation (recursive procedure, you can also use dictionary etc to store result).

Code:

Sub Demo()
Dim myItem As Outlook.mailItem
Dim oConv As Outlook.Conversation
Dim mlItem As Outlook.mailItem
    Set objApp = Outlook.Application
    Set myItem = ActiveExplorer.Selection.Item(1)
    Set oConv = myItem.GetConversation
   
    For Each mlItem In oConv.GetRootItems
        Debug.Print mlItem.CC
        Debug.Print mlItem.To
        Debug.Print mlItem.Sender
        Call CheckChildren(mlItem, oConv)
    Next
End Sub
Sub CheckChildren(oMail As Outlook.mailItem, oConv As Outlook.Conversation)
    Dim oItems As Outlook.SimpleItems
    Dim oItem As Outlook.mailItem
    Set oItems = oConv.GetChildren(oMail)
    If oItems.Count > 0 Then
        For Each oItem In oItems
            Debug.Print oItem.CC
            Debug.Print oItem.To
            Debug.Print oItem.Sender
            Call CheckChildren(oItem, oConv)
        Next
    End If
End Sub

ThrottleWorks · Jan 24, 2018

Hi @Chihiro sir, thanks for the help. I am getting bug while running macro.
'Object variable or with block variable not set' at Debug.Print oItem.Sender this line.

Could you please help if you get time.
I have one draft open at my desk. From 'Demo' module, macro goes to CheckChildren module thrice. However after 3rd or 4th instance I get above mentioned bug. Am also checking at my desk but thought I should seek you help.

Have a nice day ahead.

ThrottleWorks · Jan 24, 2018

Hi @Chihiro sir, I edited the code to suit my requirement.
However I am not getting each name or address in different cell.
With this code, multiple names or addresses are getting populated in single cell.

I am trying to get each name or address in different cell.
Will share the code if I get success.

Code:

Sub Demo()
    Dim myItem As Outlook.MailItem
    Dim oConv As Outlook.Conversation
    Dim mlItem As Outlook.MailItem
    Set MacroBook = ThisWorkbook
    Set CheckAddSht = MacroBook.Worksheets("Check Adrress here")
  
    CheckAddSht.Range("C1") = "Headers"
    TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row
    CheckAddSht.Range("C2:C65000").Clear
  
    Set objApp = Outlook.Application
    Set myItem = ActiveExplorer.Selection.Item(1)
    Set oConv = myItem.GetConversation
  
    For Each mlItem In oConv.GetRootItems
        TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
        CheckAddSht.Cells(TempLr, 3) = mlItem.CC
      
        TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
        CheckAddSht.Cells(TempLr, 3) = mlItem.To
      
        TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
        CheckAddSht.Cells(TempLr, 3) = mlItem.Sender
      
        Call CheckChildren(mlItem, oConv)
    Next
    MsgBox "Done"
End Sub
Sub CheckChildren(oMail As Outlook.MailItem, oConv As Outlook.Conversation)
    Dim oItems As Outlook.SimpleItems
    Dim oItem As Outlook.MailItem
    Set oItems = oConv.GetChildren(oMail)
    If oItems.Count > 0 Then
        For Each oItem In oItems
          
            TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
            CheckAddSht.Cells(TempLr, 3) = oItem.CC
          
            TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
            CheckAddSht.Cells(TempLr, 3) = oItem.To
          
            TempLr = CheckAddSht.Cells(CheckAddSht.Rows.Count, 3).End(xlUp).Row + 1
            CheckAddSht.Cells(TempLr, 3) = oItem.Sender
          
            Call CheckChildren(oItem, oConv)
        Next
    End If
End Sub

ThrottleWorks · Jan 24, 2018

Now I have reduced my string as below.
I need to capture each item between ';' and put it in a different cell.
Also, the catch is Cc: and last item is not separated by ';'.

For example, CCC_DD in cell B2, name surname in B3 and so on.
I do not know how to loop within string and get the data.
Can anyone please help me in this.

; CCC_DD; name surname; name surname; name surname; surname, name (OQQ); BB_Yoyer; name surname; surname, name AA AAA & AAAA AAAAA); name surname [ABCDEF]; name name surname; Cc: name surname; name surname; name surname; surname, name (A B & C D); name.surname@ab.com; surname, name (ABC ABC ABC)

Result will be something like below. Not all scenarios captured in below example.
In real scenario, I need capture every item.
CCC_DD
name surname
name surname
surname, name (OQQ)
BB_Yoyer
name.surname@ab.com
surname, name (A B & C D)

Chihiro · Jan 24, 2018

I'd recommend using Split function to split string in each field with delimiter ";".

Then putting result into dictionary to eliminate duplicates.

Will see if I have time later to look at it.

ThrottleWorks · Jan 24, 2018

Hi @Chihiro sir , thanks a lot for the help.
Done ! I forgot about using Alt D E D F. Delimiter in excel. I guess this will work for me.

ThrottleWorks · Jan 24, 2018

Hi,

I am getting issues while delimiting below dummy value.I am getting one word from this string.
Ideally there should be 3. Could you please suggest correct way to delimit string.
Names or addresses are between ';" this character. Entire string is saved in cell A1.

BB CCC DDDD DDDD; aaaaaaaaa

; aaaaaaa; aaaaaaaa
;

Value is same, just I have changed letters in value.
I am getting correct results for all other strings. However facing issues with this string only.

I am using below code. Can anyone please help me in this.

Code:

 Range("A1").Copy

    Range("C1").PasteSpecial
    Range("C1").Select
  
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, OtherChar _
    :=":", FieldInfo:=Array(Array(1, 1), _
    Array(2, 1), _
    Array(3, 1), _
    Array(4, 1), _
    Array(5, 1), _
    Array(6, 1), _
    Array(7, 1), _
    Array(8, 1), _
    Array(9, 1), _
    Array(10, 1), Array(11, 1), Array(12 _
    , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
    Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
    25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), _
    Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
    38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
    Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
    51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), _
    Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array( _
    64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), _
    Array(70, 1), Array(71, 1), Array(72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), _
    Array(77, 1), Array(78, 1), Array(79, 1), Array(80, 1)), TrailingMinusNumbers:=True
  
    Range("D1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy

ThrottleWorks · Jan 25, 2018

Hi,

I have created this dummy string.

1B CCC CCCCCCC DDDD, 2EEEEEEEE

, 3QQQQQQQQQQQQ, 4CCCCCCCCCCCC

,
And I am manually doing Alt D E D F to get the result.
I am getting result as 1B CCC CCCCCCC DDDD and 2EEEEEEEE.
3QQQQQQQQQQQQ and 4CCCCCCCCCCCC are skipped by excel.

Not able to understand why this is happening.

ThrottleWorks · Jan 25, 2018

Hi,

This code seems to be working for me. Please give me some time to revert.

https://stackoverflow.com/questions/24989043/vba-split-string-loop

Code:

Sub SplitStringLoop()

    Dim txt As String
    Dim i As Integer
    Dim y As Integer
    Dim FullName As Variant
    Dim LastRow As Single
   
    ReDim FullName(3)
    LastRow = 1
    txt = Range("A1").Value
   
    FullName = Split(txt, ";")
   
    For y = 1 To LastRow
        For i = 1 To UBound(FullName)
            Cells(y, i + 1).Value = FullName(i)
        Next i
    Next y
End Sub

How to copy partial e-mail body in excel

ThrottleWorks

Excel Ninja

Chihiro

Excel Ninja

Chihiro

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

Chihiro

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

Chihiro

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja

ThrottleWorks

Excel Ninja