Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17


Part 6 to: Import more data into spreadsheet

Posted on 2013-06-13
Medium Priority
Last Modified: 2013-06-13
This is the 6th continuation of Import more data into spreadsheet, the last one being:

Now we need to extract data from an email that is an order from the website, or not. Here's what we need to do:

1. WHEN the email is selected in Outlook and has an order number in the subject: "Order 486" or any number after the word "Order" THEN insert "WO 486" (for Web Order 486) in Col i, Origin. So if it has "Order 787" in the subject of the email, insert "WO 787" in Col i of Applicant Status for that record.

2. WHEN the email is selected in Outlook and does NOT have an Order Number in the subject THEN insert the email address extracted the from email address into Col i.

So if an email comes in from for example,, then when I select it in Outlook and hit the Save Links button IF that email's subject does NOT have "Order xxx" THEN insert '' into Col i.

Attached is a screenshot of an email that comes in as a web order.
order email
Question by:JaseSt
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
LVL 31

Accepted Solution

gowflow earned 2000 total points
ID: 39245082
ok here it is

1) Make a copy of your latest file and give it a new name
2) goto VBA and select Saveattachements sub and delete it.
3) Copy paste the below code after any End Sub

Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String
Dim lOrder As Long
Dim sOrder As String

    Set WS = ActiveSheet
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                On Error Resume Next
                    objAttachments.Item(I).SaveAsFile strFile
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                '---> Insert Order Number
                If InStr(1, LCase(objMsg.Subject), "order") <> 0 Then
                    lOrder = InStr(1, LCase(objMsg.Subject), "order") + 6
                    sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)
                    WS.Range("I" & cCell.Row) = "WO " & sOrder
                    WS.Range("I" & cCell.Row) = objMsg.SenderEmailAddress
                End If
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                '---> Check to See if Valid Excel File
                If InStr(1, LCase(FileExt), "xls") <> 0 Or InStr(1, LCase(FileExt), "xlsm") <> 0 Or InStr(1, LCase(FileExt), "xltx") <> 0 Or InStr(1, LCase(FileExt), "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If InStr(1, LCase(WSAttach.Range("A1")), "first name") <> 0 And InStr(1, LCase(WSAttach.Range("B1")), "last name") <> 0 And InStr(1, LCase(WSAttach.Range("O1")), "email address") <> 0 Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        '---> Depending on Value of Col P affect Col T
                        If InStr(1, LCase(WSAttach.Range("P1")), "card number") <> 0 Then
                            WS.Range("T" & cCell.Row).NumberFormat = "Text"
                            WS.Range("T" & cCell.Row) = WSAttach.Range("P2")
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                    End If
                    '---> Close Workbook
                    WB.Close SaveChanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                        Open strFile For Input As #1
                        KK = 99
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                            If UBound(sLine) = 0 Then
                                lTo = 0
                                lTo = 1
                            End If
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                    If InStr(1, sFields(KK), "@") = 0 Then
                                        For KK = 0 To UBound(sFields)
                                            If InStr(1, sFields(KK), "@") <> 0 Then Exit For
                                        Next KK
                                    End If
                                End If
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                            Next L
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                End If
            Next I
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox (lngCount & " Attachments were saved on C drive")

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub

End Sub

Open in new window

4) SAVE and Exit the workbook.
5) open it and give it a try


Author Closing Comment

ID: 39245282
Wow! You're quick. It works, thank you!

Have another thing or two or three to do with this spreadsheet and will post here if you're ok with that.
LVL 31

Expert Comment

ID: 39245287
yes shoot while wer' at it

Featured Post

 [eBook] Windows Nano Server

Download this FREE eBook and learn all you need to get started with Windows Nano Server, including deployment options, remote management
and troubleshooting tips and tricks

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will help to fix the below error for MS Exchange server 2010 I. Out Of office not working II. Certificate error "name on the security certificate is invalid or does not match the name of the site" III. Make Internal URLs and External…
This article describes how to import Lotus Notes Contacts into Outlook 2016, 2013, 2010 and 2007 etc. with a few manual steps. You can easily export and migrate Lotus Notes contacts into Microsoft Outlook without having to use any third party tools.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
There are cases when e.g. an IT administrator wants to have full access and view into selected mailboxes on Exchange server, directly from his own email account in Outlook or Outlook Web Access. This proves useful when for example administrator want…

715 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question