Option Explicit Sub CopyToExcel(olItem As MailItem) Dim olApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim olFolder As Outlook.MAPIFolder Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim gaFolder As Folder Dim teFolder As Folder Dim vText As Variant Dim sText As String Dim sAddr As String Dim vAddr As Variant Dim vItem As Variant Dim i As Long, j As Long Dim rCount As Long Dim bXStarted As Boolean Dim ga As String, te As String, sg As String, ot As String, re As String Dim ga2 As String, te2 As String, sg2 As String, ot2 As String, re2 As String Const strWorkSheetName As String = "Sheet2" Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsm" 'the path of the workbook Set olApp = Outlook.Application Set objNS = olApp.GetNamespace("MAPI") Set olFolder = objNS.GetDefaultFolder(olFolderInbox) Set teFolder = olFolder.Folders("Tank & Enclosure") Set gaFolder = olFolder.Folders("Generator and ATS") 'Open the workbook to input the data Set xlWB = Excel.Workbooks.Open("C:\Users\ko98240\Desktop\Book1.xlsm") Set xlSheet = xlWB.Sheets("Sheet2") 'Process the message With olItem sText = olItem.Body vText = Split(sText, Chr(13)) 'Find the next empty line of the worksheet rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1 'Check each line of text in the message body For i = UBound(vText) To 0 Step -1 If InStr(1, vText(i), "Job Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("A" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Contact Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Company:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Generator and ATS:") > 0 Then vItem = Split(vText(i), Chr(58)) ga = "Generator and ATS: " & Trim(vItem(1)) ga2 = Trim(vItem(1)) End If If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then vItem = Split(vText(i), Chr(58)) te = "Tank & Enclosure: " & Trim(vItem(1)) te2 = Trim(vItem(1)) End If If InStr(1, vText(i), "Switchgear:") > 0 Then vItem = Split(vText(i), Chr(58)) sg = "Switchgear: " & Trim(vItem(1)) sg2 = Trim(vItem(1)) End If If InStr(1, vText(i), "Other:") > 0 Then vItem = Split(vText(i), Chr(58)) ot = "Other: " & Trim(vItem(1)) ot2 = Trim(vItem(1)) End If If InStr(1, vText(i), "Revisions:") > 0 Then vItem = Split(vText(i), Chr(58)) re = "Revisions: " & Trim(vItem(1)) re2 = Trim(vItem(1)) End If Next i 'Move the incoming email to appropriate sub inbox If ((Len(ga2) > 0) And (Len(te2) = 0)) Then olItem.Move gaFolder ElseIf ((Len(sg2) > 0) And (Len(te2) = 0)) Then olItem.Move gaFolder ElseIf ((Len(ot2) > 0) And (Len(te2) = 0)) Then olItem.Move gaFolder ElseIf ((Len(re2) > 0) And (Len(te2) = 0)) Then olItem.Move gaFolder Else olItem.Move teFolder End If 'Copy notes to one note field xlSheet.Range("D" & rCount) = ga & " " & te & " " & sg & " " & ot & " " & re 'Separate date and time from time stamp xlSheet.Range("E" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy") xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "hh:mm:ss AM/PM") xlWB.Save End With xlWB.Close SaveChanges:=True If bXStarted Then xlApp.Quit End If Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing End Sub