Announcement

Collapse
No announcement yet.

Exporting a body of an email to excel using VBA

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Exporting a body of an email to excel using VBA

    Hi,

    Everyday i get a email with the body in a text format which i normally do the boring Crtl A and paste special = Text. Is there a VBA code for office 2007 that can automate this process

    Details of the email:
    This email has the same title every day which i have a rule that moves it to my "personal folder/report" folder. i have seen multiple threads that look for the title but can the VBA code look for todays date and specific times (10:30am daily this report lands)
    email name = Unbilled invoice report

    What i would like is if somebody could help me with creating this VBA script so that i can click a import button (which i can create basics i know lol) in excel and excel will go to outlook and find the email and paste the contents in to A5 as text but line by line not all contents in to the cell A5. My knowledge in VBA is as limited to clicking record and being able to remove junk data thats been recorded. i am currently trying to learn more and more and would apprciate any input.

    thanks
    Jase

  • #2
    Re: Exporting a body of an email to excel using VBA

    You don't have all the details of the email you are receiving but here is something I just built and wanted to put it out there as it may be useful to someone else. It's not pretty but it works for my purposes. I am using it in 2003 but it can easily be updated for greater rows in 2007.

    I have a template file with a sheet named "Import" and a basic shape called "Rectangle 1" that is assigned to run this macro.

    The emails I receive are moved to a folder and this will cycle through that folder and copy the message body to column A. The emails all contain certain tags/labels that I use to parse out the data I want. The folder isn't named in the macro it is selected by the user running the macro.

    You could start with this and change it to suit your needs by changing the formulas I have to parse out the data. I am sure there is a better way to do this but this works for me and is quick (my boss used to manually go through hundreds of these emails at the end of every month and retype them into a sheet).

    Code:
    Sub ImportOutlook()
    
    
    Application.ScreenUpdating = False
    
    
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    
    
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    
    
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim itm As Object
    Dim sFileDate As String
    
    
    'File date
    sFileDate = Format(Now, "YYYYMMDD")
    
    
    'Delete macro button
    Sheets("Import").Activate
    ActiveSheet.Shapes("Rectangle 1").Delete
    
    
    'Select import folder
    Set nms = GetObject("", "Outlook.Application").GetNamespace("MAPI")
    Set fld = nms.PickFolder
    
    
    'Handle potential errors with Select Folder dialog box
    If fld Is Nothing Then
        
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Application.ScreenUpdating = True
        Exit Sub
        
        ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Application.ScreenUpdating = True
        Exit Sub
        
        ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, _
        "Error"
        Application.ScreenUpdating = True
        Exit Sub
    
    
    End If
    
    
    Set wkb = ActiveWorkbook
    Set wks = wkb.Sheets("Import")
    wks.Activate
    
    
    intRowCounter = 1
    
    
    'Copy field items in mail folder.
    For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = intRowCounter + 1
    
    
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.Body
    intColumnCounter = intColumnCounter + 1
    
    
    Next itm
    
    
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    
    
    'Determine data range
    LastUsedRow = Worksheets("Import").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    
    
    'Parse out values
    Sheets("Import").Select
    Range("B2").Formula = "=MID(Trim(Clean(A2)),FIND(""Risk Owner:"",Trim(Clean(A2)))+13,FIND(""Counterparty:"",Trim(Clean(A2)))-FIND(""Risk Owner:"",Trim(Clean(A2)))-13)"
    Range("C2").Formula = "=MID(Trim(Clean(A2)),FIND(""Counterparty:"",Trim(Clean(A2)))+15,FIND(""Trade ID:"",Trim(Clean(A2)))-FIND(""Counterparty:"",Trim(Clean(A2)))-15)"
    Range("D2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Trade ID:"",TRIM(CLEAN(A2)))+11,FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))-FIND(""Trade ID:"",TRIM(CLEAN(A2)))-11)"
    Range("E2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))+13,FIND(""Termination Method:"",TRIM(CLEAN(A2)))-FIND(""Fee Leg ID:"",TRIM(CLEAN(A2)))-13)"
    Range("F2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Termination Method:"",TRIM(CLEAN(A2)))+21,FIND(""Termination amount:"",TRIM(CLEAN(A2)))-FIND(""Termination Method:"",TRIM(CLEAN(A2)))-21)"
    Range("G2").Formula = "=MID(TRIM(CLEAN(A2)),FIND(""Termination amount:"",TRIM(CLEAN(A2)))+21,FIND(""Expected Recovery:"",TRIM(CLEAN(A2)))-FIND(""Termination amount:"",TRIM(CLEAN(A2)))-21)"
    
    
    'Copy formulas
    Sheets("Import").Select
    Range("B2").Select
    Selection.AutoFill Destination:=Range("B2:B" & LastUsedRow), Type:=xlFillDefault
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C" & LastUsedRow), Type:=xlFillDefault
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D" & LastUsedRow), Type:=xlFillDefault
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E" & LastUsedRow), Type:=xlFillDefault
    Range("F2").Select
    Selection.AutoFill Destination:=Range("F2:F" & LastUsedRow), Type:=xlFillDefault
    Range("G2").Select
    Selection.AutoFill Destination:=Range("G2:G" & LastUsedRow), Type:=xlFillDefault
    
    
    'Paste values to remove formulas
    Sheets(Array("Import")).Select
    Sheets("Import").Activate
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    
    'Delete email message body
    Sheets("Import").Activate
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    
    
    'Formatting
    Cells.Columns.AutoFit
    
    
    Columns("C:C").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
    
    
    Columns("D:D").Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
            
    Columns("F:F").Select
    Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
            :=Array(1, 1), TrailingMinusNumbers:=True
    
    
    Columns("F:F").Select
    Selection.Style = "Currency"
    
    
    Application.GoTo Sheets("Import").Range("A1"), True
    
    
    Application.ScreenUpdating = True
    
    
    'Save As
    ActiveWorkbook.SaveAs Filename:=("C:\WINDOWS\Temp" & "\OutlookImport_" & sFileDate & ".xls"), FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    
    
    Exit Sub
    
    
    ErrHandler:  If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
    "Error"
    
    
    Else
    MsgBox Err.Number & "; Description: ", vbOKOnly, _
    "Error"
    
    
    End If
    
    
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    
    
    Application.ScreenUpdating = True
    
    
    End Sub

    Comment


    • #3
      Re: Exporting a body of an email to excel using VBA

      Not sure how to edit my last post but it might be helpful to see the email. The emails can have other text before or after or have signature or no signature etc or be forwarded but the macro is dependent on these tags/labels being present in body of the email in the same order. I have removed identifying details but basically it will parse out the data between the tags of any length.

      Risk Owner: xxxxxx
      Counterparty: xxxxx
      Trade ID: ########
      Fee Leg ID: #######
      Termination Method: xxxxxx
      Termination amount: ########
      Expected Recovery: xxxxxxxxxxxxxxxxxxxxxxx

      Comment

      Working...
      X